/* Part of SWI-Prolog Author: Jan Wielemaker E-mail: J.Wielemaker@vu.nl WWW: http://www.swi-prolog.org Copyright (c) 2019, University of Amsterdam VU University Amsterdam CWI, Amsterdam All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ #include "pl-incl.h" #include "pl-comp.h" #include "pl-event.h" #include "pl-dbref.h" #include "pl-copyterm.h" /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Event interface - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #ifdef O_PLMT #define INIT_LIST_LOCK(l) recursiveMutexInit(&(l)->lock) #define DELETE_LIST_LOCK(l) recursiveMutexDelete(&(l)->lock) #define LOCK_LIST(l) recursiveMutexLock(&(l)->lock) #define UNLOCK_LIST(l) recursiveMutexUnlock(&(l)->lock) #else #define INIT_LIST_LOCK(l) #define DELETE_LIST_LOCK(l) #define LOCK_LIST(l) #define UNLOCK_LIST(l) #endif #define EV_GLOBAL(name) (&GD->event.hook.name) #define EV_LOCAL(name) (&((PL_local_data_t*)NULL)->event.hook.name) #define GEVENT(id, name, ac, loc) {id, name, ac, FALSE, EV_GLOBAL(loc) } #define LEVENT(id, name, ac, loc) {id, name, ac, TRUE, EV_LOCAL(loc) } const event_type PL_events[] = { GEVENT(PLEV_ABORT, ATOM_abort, 0, onabort), GEVENT(PLEV_ERASED_CLAUSE, ATOM_erase, 1, onerase), GEVENT(PLEV_ERASED_RECORD, ATOM_erase, 1, onerase), GEVENT(PLEV_BREAK, ATOM_break, 3, onbreak), GEVENT(PLEV_BREAK_EXISTS, ATOM_break, 3, onbreak), GEVENT(PLEV_NOBREAK, ATOM_break, 3, onbreak), GEVENT(PLEV_GCNOBREAK, ATOM_break, 3, onbreak), GEVENT(PLEV_FRAMEFINISHED, ATOM_frame_finished, 1, onframefinish), GEVENT(PLEV_UNTABLE, ATOM_untable, 1, onuntable), #ifdef O_PLMT GEVENT(PLEV_THREAD_EXIT, ATOM_thread_exit, 1, onthreadexit), LEVENT(PLEV_THIS_THREAD_EXIT, ATOM_this_thread_exit, 0, onthreadexit), #endif {0} }; static int link_event(event_list *list, event_callback *cb, int last) { LOCK_LIST(list); if ( !list->head ) { list->head = list->tail = cb; } else if ( last ) { list->tail->next = cb; list->tail = cb; } else { cb->next = list->head; list->head = cb; } UNLOCK_LIST(list); return TRUE; } static int get_callback(term_t closure, Module *m, term_t cb ARG_LD) { if ( !PL_strip_module(closure, m, cb) ) return FALSE; if ( !PL_is_callable(cb) ) return PL_type_error("callable", closure); return TRUE; } static int add_event_hook(event_list *list, int last, term_t closure, int argc) { GET_LD Module m = NULL; event_callback *cb; atom_t name; term_t t = PL_new_term_ref(); if ( !get_callback(closure, &m, t PASS_LD) ) return FALSE; cb = PL_malloc(sizeof(*cb)); memset(cb, 0, sizeof(*cb)); cb->argc = argc; cb->module = m; if ( PL_get_atom(t, &name) ) { cb->procedure = resolveProcedure(PL_new_functor(name, argc), m); } else { cb->procedure = PL_predicate("call", argc+1, "system"); cb->closure.term = term_to_fastheap(closure PASS_LD); } return link_event(list, cb, last); } static event_list * get_event_list(event_list **list) { if ( !*list ) { PL_LOCK(L_EVHOOK); if ( !*list ) { event_list *l = PL_malloc(sizeof(*l)); memset(l, 0, sizeof(*l)); INIT_LIST_LOCK(l); *list = l; } PL_UNLOCK(L_EVHOOK); } return *list; } int register_event_hook(event_list **list, int last, term_t closure, int argc) { return add_event_hook(get_event_list(list), last, closure, argc); } static int get_event_listp(term_t type, event_list ***listpp, size_t *argc ARG_LD) { atom_t name; size_t arity; if ( PL_get_name_arity(type, &name, &arity) ) { const event_type *et; Procedure proc; if ( arity == 0 ) { for(et=PL_events; et->name; et++) { if ( et->name == name ) { assert(et->id == et-PL_events); *listpp = event_list_location(et->id); *argc = et->argc; return TRUE; } } } else if ( get_procedure(type, &proc, 0, GP_FIND|GP_NAMEARITY) ) { *listpp = &proc->definition->events; *argc = 2; /* action, cref */ return TRUE; } return PL_domain_error("event", type); } return PL_type_error("callable", type); } static const opt_spec prolog_listen_options[] = { { ATOM_as, OPT_ATOM }, { NULL_ATOM, 0 } }; static int prolog_listen(term_t type, term_t closure, term_t options ARG_LD) { event_list **listp; size_t argc; atom_t as = ATOM_first; if ( options && !scan_options(options, 0, /*OPT_ALL,*/ ATOM_prolog_listen_option, prolog_listen_options, &as) ) return FALSE; if ( !(as == ATOM_first || as == ATOM_last) ) { term_t ex = PL_new_term_ref(); return PL_put_atom(ex, as) && PL_domain_error("as", ex); } if ( get_event_listp(type, &listp, &argc PASS_LD) ) return register_event_hook(listp, as == ATOM_last, closure, argc); return FALSE; } static PRED_IMPL("prolog_listen", 2, prolog_listen, META) { PRED_LD return prolog_listen(A1, A2, 0 PASS_LD); } static PRED_IMPL("prolog_listen", 3, prolog_listen, META) { PRED_LD return prolog_listen(A1, A2, A3 PASS_LD); } static PRED_IMPL("prolog_unlisten", 2, prolog_unlisten, 0) { PRED_LD event_list **listp; size_t argc; if ( get_event_listp(A1, &listp, &argc PASS_LD) ) { event_list *list; if ( (list = *listp) ) { Module m = NULL; term_t t = PL_new_term_ref(); atom_t name = 0; event_callback *ev, *next, *prev = NULL; fid_t fid = PL_open_foreign_frame(); term_t tmp = PL_new_term_ref(); Procedure proc = NULL; if ( !get_callback(A2, &m, t PASS_LD) ) return FALSE; if ( PL_get_atom(t, &name) ) proc = resolveProcedure(PL_new_functor(name, argc), m); LOCK_LIST(list); for(ev = list->head; ev; ev = next) { next = ev->next; if ( !ev->function ) { if ( proc ) { if ( ev->procedure->definition == proc->definition ) { delete: if ( prev ) { prev->next = ev->next; } else { list->head = ev->next; if ( !list->head ) list->tail = NULL; } continue; } } else if ( ev->closure.term ) { if ( put_fastheap(ev->closure.term, tmp PASS_LD) && PL_unify(A2, tmp) ) goto delete; if ( PL_exception(0) ) { UNLOCK_LIST(list); return FALSE; } PL_rewind_foreign_frame(fid); } } prev = ev; } UNLOCK_LIST(list); } return TRUE; } return FALSE; } int register_event_function(event_list **list, int last, int (*func)(), void *closure, int argc) { event_callback *cb = PL_malloc(sizeof(*cb)); memset(cb, 0, sizeof(*cb)); cb->argc = argc; cb->function = func; cb->closure.pointer = closure; return link_event(get_event_list(list), cb, last); } static void free_event_callback(event_callback *cb) { if ( !cb->function && cb->closure.term ) free_fastheap(cb->closure.term); PL_free(cb); } void destroy_event_list(event_list **listp) { event_list *list = *listp; if ( list ) { event_callback *cb, *next; *listp = NULL; for(cb=list->head; cb; cb = next) { next = cb->next; free_event_callback(cb); } DELETE_LIST_LOCK(list); PL_free(list); } } static int call_event_list(event_list *list, int argc, term_t argv ARG_LD) { int rc = TRUE; if ( list ) { event_callback *ev; LOCK_LIST(list); for(ev = list->head; ev; ev = ev->next) { if ( ev->function ) { switch(argc) { case 0: rc = (*ev->function)(ev->closure.pointer); break; case 1: rc = (*ev->function)(ev->closure.pointer, argv+1); break; case 2: rc = (*ev->function)(ev->closure.pointer, argv+1, argv+2); break; default: rc = FALSE; assert(0); } } else if ( ev->closure.term ) { rc = rc && ( put_fastheap(ev->closure.term, argv PASS_LD) && PL_call_predicate(ev->module, PL_Q_NODEBUG|PL_Q_PASS_EXCEPTION, ev->procedure, argv) ); } else { assert(ev->argc == argc); rc = rc && PL_call_predicate(NULL, PL_Q_NODEBUG|PL_Q_PASS_EXCEPTION, ev->procedure, argv+1); } if ( !rc && PL_exception(0) ) break; } UNLOCK_LIST(list); } return rc; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - callEventHook() is used to call Prolog in debugger related events that happen in the system. In some cases, these events are generated while the system holds locks. Such code should call delayEvents() and sendDelayedEvents(). These calls must be properly nested. Delaying is currently only implemented for PLEV_BREAK and PLEV_NOBREAK. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ typedef struct delayed_event { pl_event_type type; /* PLEV_* */ union { struct { Clause clause; int offset; } pc; struct { Clause clause; } clause; struct { Procedure proc; } proc; } value; } delayed_event; static int delayEvent(pl_event_type ev, va_list args) { GET_LD if ( LD->event.buffered ) { delayed_event dev; dev.type = ev; switch(ev) { case PLEV_BREAK_EXISTS: case PLEV_BREAK: case PLEV_NOBREAK: case PLEV_GCNOBREAK: dev.value.pc.clause = va_arg(args, Clause); dev.value.pc.offset = va_arg(args, int); acquire_clause(dev.value.pc.clause); break; case PLEV_ERASED_CLAUSE: dev.value.clause.clause = va_arg(args, Clause); acquire_clause(dev.value.pc.clause); break; case PLEV_UNTABLE: dev.value.proc.proc = va_arg(args, Procedure); break; default: assert(0); } addBuffer(LD->event.buffered, dev, delayed_event); } return TRUE; } int delayEvents(void) { GET_LD if ( !LD->event.delay_nesting++ ) { assert(!LD->event.buffered); if ( (LD->event.buffered = malloc(sizeof(tmp_buffer))) ) { initBuffer(LD->event.buffered); return TRUE; } } return FALSE; } /* Returns -1: an exception occurred while sending events N: number of events sent */ int sendDelayedEvents(int noerror) { GET_LD int sent = 0; if ( --LD->event.delay_nesting == 0 ) { Buffer b = LD->event.buffered; delayed_event *dev = baseBuffer(b, delayed_event); int count = entriesBuffer(b, delayed_event); LD->event.buffered = NULL; for(; count-- > 0; dev++) { if ( noerror ) { switch(dev->type) { case PLEV_BREAK_EXISTS: case PLEV_BREAK: case PLEV_NOBREAK: case PLEV_GCNOBREAK: noerror = callEventHook(dev->type, dev->value.pc.clause, dev->value.pc.offset); sent++; release_clause(dev->value.pc.clause); break; case PLEV_ERASED_CLAUSE: noerror = callEventHook(dev->type, dev->value.clause.clause); sent++; release_clause(dev->value.pc.clause); break; case PLEV_UNTABLE: noerror = callEventHook(dev->type, dev->value.proc.proc); sent++; break; default: assert(0); } } } discardBuffer(b); free(b); } return noerror ? sent : -1; } int PL_call_event_hook(pl_event_type ev, ...) { event_list **listp = event_list_location(ev); if ( *listp && GD->cleaning != CLN_DATA ) { va_list args; int rc; va_start(args, ev); rc = PL_call_event_hook_va(ev, args); va_end(args); return rc; } return TRUE; } /* Returns FALSE iff there is an exception inside the execution of the * hook */ int PL_call_event_hook_va(pl_event_type ev, va_list args) { GET_LD wakeup_state wstate; int rc = TRUE; event_list *list = *event_list_location(ev); term_t av; const event_type *event_decl = &PL_events[ev]; if ( LD->event.delay_nesting ) { delayEvent(ev, args); return TRUE; } if ( !saveWakeup(&wstate, TRUE PASS_LD) ) return FALSE; av = PL_new_term_refs(event_decl->argc+1); switch(ev) { case PLEV_ABORT: break; case PLEV_ERASED_CLAUSE: { Clause cl = va_arg(args, Clause); /* object erased */ rc = PL_put_clref(av+1, cl); break; } case PLEV_ERASED_RECORD: { RecordRef r = va_arg(args, RecordRef); /* object erased */ rc = PL_unify_recref(av+1, r); break; } case PLEV_BREAK: case PLEV_BREAK_EXISTS: case PLEV_NOBREAK: case PLEV_GCNOBREAK: { Clause cl = va_arg(args, Clause); int offset = va_arg(args, int); rc = ( PL_put_atom(av+1, ev == PLEV_BREAK ? ATOM_true : ev == PLEV_NOBREAK ? ATOM_false : ev == PLEV_GCNOBREAK ? ATOM_gc : ATOM_exist) && PL_put_clref(av+2, cl) && PL_put_intptr(av+3, offset) ); break; } case PLEV_FRAMEFINISHED: { LocalFrame fr = va_arg(args, LocalFrame); rc = PL_put_frame(av+1, fr); break; } #ifdef O_PLMT case PLEV_THREAD_EXIT: { PL_thread_info_t *info = va_arg(args, PL_thread_info_t*); rc = unify_thread_id(av+1, info); break; } case PLEV_THIS_THREAD_EXIT: break; #endif case PLEV_UNTABLE: { Procedure proc = va_arg(args, Procedure); rc = unify_definition(NULL, av+1, proc->definition, 0, GP_QUALIFY|GP_NAMEARITY); break; } default: rc = warning("callEventHook(): unknown event: %d", ev); goto out; } if ( rc ) { rc = call_event_list(list, event_decl->argc, av PASS_LD); if ( !rc && PL_exception(0) ) set(&wstate, WAKEUP_KEEP_URGENT_EXCEPTION); else rc = TRUE; /* only FALSE on error */ } out: restoreWakeup(&wstate PASS_LD); return rc; } int predicate_update_event(Definition def, atom_t action, Clause cl ARG_LD) { wakeup_state wstate; term_t av; int rc = TRUE; if ( !saveWakeup(&wstate, TRUE PASS_LD) ) return FALSE; av = PL_new_term_refs(3); /* closure, action, clause */ if ( !PL_put_atom(av+1, action) || !PL_put_clref(av+2, cl) ) return FALSE; rc = call_event_list(def->events, 2, av PASS_LD); restoreWakeup(&wstate PASS_LD); return rc; } int retractall_event(Definition def, term_t head, functor_t start ARG_LD) { wakeup_state wstate; term_t av; int rc = TRUE; if ( !saveWakeup(&wstate, TRUE PASS_LD) ) return FALSE; av = PL_new_term_refs(4); /* closure, action, start/end, head */ if ( !PL_put_atom(av+1, def->module->name) || !PL_put_term(av+2, head) || !PL_cons_functor_v(av+2, FUNCTOR_colon2, av+1) || !PL_cons_functor_v(av+2, start, av+2) || !PL_put_atom(av+1, ATOM_retractall) ) return FALSE; rc = call_event_list(def->events, 2, av PASS_LD); restoreWakeup(&wstate PASS_LD); return rc; } /******************************* * PUBLISH PREDICATES * *******************************/ #define META PL_FA_TRANSPARENT BeginPredDefs(event) PRED_DEF("prolog_listen", 2, prolog_listen, META) PRED_DEF("prolog_listen", 3, prolog_listen, META) PRED_DEF("prolog_unlisten", 2, prolog_unlisten, META) EndPredDefs