1 /* Part of SWI-Prolog
2
3 Author: Jan Wielemaker
4 E-mail: J.Wielemaker@vu.nl
5 WWW: http://www.swi-prolog.org
6 Copyright (c) 2019, University of Amsterdam
7 VU University Amsterdam
8 CWI, Amsterdam
9 All rights reserved.
10
11 Redistribution and use in source and binary forms, with or without
12 modification, are permitted provided that the following conditions
13 are met:
14
15 1. Redistributions of source code must retain the above copyright
16 notice, this list of conditions and the following disclaimer.
17
18 2. Redistributions in binary form must reproduce the above copyright
19 notice, this list of conditions and the following disclaimer in
20 the documentation and/or other materials provided with the
21 distribution.
22
23 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
24 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
25 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
26 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
27 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
28 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
29 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
30 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
31 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
33 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34 POSSIBILITY OF SUCH DAMAGE.
35 */
36
37 #include "pl-incl.h"
38 #include "pl-comp.h"
39 #include "pl-event.h"
40 #include "pl-dbref.h"
41 #include "pl-copyterm.h"
42
43 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
44 Event interface
45 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
46
47 #ifdef O_PLMT
48 #define INIT_LIST_LOCK(l) recursiveMutexInit(&(l)->lock)
49 #define DELETE_LIST_LOCK(l) recursiveMutexDelete(&(l)->lock)
50 #define LOCK_LIST(l) recursiveMutexLock(&(l)->lock)
51 #define UNLOCK_LIST(l) recursiveMutexUnlock(&(l)->lock)
52 #else
53 #define INIT_LIST_LOCK(l)
54 #define DELETE_LIST_LOCK(l)
55 #define LOCK_LIST(l)
56 #define UNLOCK_LIST(l)
57 #endif
58
59 #define EV_GLOBAL(name) (&GD->event.hook.name)
60 #define EV_LOCAL(name) (&((PL_local_data_t*)NULL)->event.hook.name)
61 #define GEVENT(id, name, ac, loc) {id, name, ac, FALSE, EV_GLOBAL(loc) }
62 #define LEVENT(id, name, ac, loc) {id, name, ac, TRUE, EV_LOCAL(loc) }
63
64 const event_type PL_events[] =
65 { GEVENT(PLEV_ABORT, ATOM_abort, 0, onabort),
66 GEVENT(PLEV_ERASED_CLAUSE, ATOM_erase, 1, onerase),
67 GEVENT(PLEV_ERASED_RECORD, ATOM_erase, 1, onerase),
68 GEVENT(PLEV_BREAK, ATOM_break, 3, onbreak),
69 GEVENT(PLEV_BREAK_EXISTS, ATOM_break, 3, onbreak),
70 GEVENT(PLEV_NOBREAK, ATOM_break, 3, onbreak),
71 GEVENT(PLEV_GCNOBREAK, ATOM_break, 3, onbreak),
72 GEVENT(PLEV_FRAMEFINISHED, ATOM_frame_finished, 1, onframefinish),
73 GEVENT(PLEV_UNTABLE, ATOM_untable, 1, onuntable),
74 #ifdef O_PLMT
75 GEVENT(PLEV_THREAD_EXIT, ATOM_thread_exit, 1, onthreadexit),
76 LEVENT(PLEV_THIS_THREAD_EXIT, ATOM_this_thread_exit, 0, onthreadexit),
77 #endif
78 {0}
79 };
80
81 static int
link_event(event_list * list,event_callback * cb,int last)82 link_event(event_list *list, event_callback *cb, int last)
83 { LOCK_LIST(list);
84 if ( !list->head )
85 { list->head = list->tail = cb;
86 } else if ( last )
87 { list->tail->next = cb;
88 list->tail = cb;
89 } else
90 { cb->next = list->head;
91 list->head = cb;
92 }
93 UNLOCK_LIST(list);
94
95 return TRUE;
96 }
97
98
99 static int
get_callback(term_t closure,Module * m,term_t cb ARG_LD)100 get_callback(term_t closure, Module *m, term_t cb ARG_LD)
101 { if ( !PL_strip_module(closure, m, cb) )
102 return FALSE;
103 if ( !PL_is_callable(cb) )
104 return PL_type_error("callable", closure);
105
106 return TRUE;
107 }
108
109
110 static int
add_event_hook(event_list * list,int last,term_t closure,int argc)111 add_event_hook(event_list *list, int last, term_t closure, int argc)
112 { GET_LD
113 Module m = NULL;
114 event_callback *cb;
115 atom_t name;
116 term_t t = PL_new_term_ref();
117
118 if ( !get_callback(closure, &m, t PASS_LD) )
119 return FALSE;
120
121 cb = PL_malloc(sizeof(*cb));
122 memset(cb, 0, sizeof(*cb));
123 cb->argc = argc;
124 cb->module = m;
125
126 if ( PL_get_atom(t, &name) )
127 { cb->procedure = resolveProcedure(PL_new_functor(name, argc), m);
128 } else
129 { cb->procedure = PL_predicate("call", argc+1, "system");
130 cb->closure.term = term_to_fastheap(closure PASS_LD);
131 }
132
133 return link_event(list, cb, last);
134 }
135
136
137 static event_list *
get_event_list(event_list ** list)138 get_event_list(event_list **list)
139 { if ( !*list )
140 { PL_LOCK(L_EVHOOK);
141 if ( !*list )
142 { event_list *l = PL_malloc(sizeof(*l));
143
144 memset(l, 0, sizeof(*l));
145 INIT_LIST_LOCK(l);
146 *list = l;
147 }
148 PL_UNLOCK(L_EVHOOK);
149 }
150
151 return *list;
152 }
153
154 int
register_event_hook(event_list ** list,int last,term_t closure,int argc)155 register_event_hook(event_list **list, int last, term_t closure, int argc)
156 { return add_event_hook(get_event_list(list), last, closure, argc);
157 }
158
159
160 static int
get_event_listp(term_t type,event_list *** listpp,size_t * argc ARG_LD)161 get_event_listp(term_t type, event_list ***listpp, size_t *argc ARG_LD)
162 { atom_t name;
163 size_t arity;
164
165 if ( PL_get_name_arity(type, &name, &arity) )
166 { const event_type *et;
167 Procedure proc;
168
169 if ( arity == 0 )
170 { for(et=PL_events; et->name; et++)
171 { if ( et->name == name )
172 { assert(et->id == et-PL_events);
173 *listpp = event_list_location(et->id);
174 *argc = et->argc;
175
176 return TRUE;
177 }
178 }
179 } else if ( get_procedure(type, &proc, 0, GP_FIND|GP_NAMEARITY) )
180 { *listpp = &proc->definition->events;
181 *argc = 2; /* action, cref */
182
183 return TRUE;
184 }
185
186 return PL_domain_error("event", type);
187 }
188
189 return PL_type_error("callable", type);
190 }
191
192 static const opt_spec prolog_listen_options[] =
193 { { ATOM_as, OPT_ATOM },
194 { NULL_ATOM, 0 }
195 };
196
197 static int
prolog_listen(term_t type,term_t closure,term_t options ARG_LD)198 prolog_listen(term_t type, term_t closure, term_t options ARG_LD)
199 { event_list **listp;
200 size_t argc;
201 atom_t as = ATOM_first;
202
203 if ( options && !scan_options(options, 0, /*OPT_ALL,*/
204 ATOM_prolog_listen_option, prolog_listen_options,
205 &as) )
206 return FALSE;
207
208 if ( !(as == ATOM_first || as == ATOM_last) )
209 { term_t ex = PL_new_term_ref();
210 return PL_put_atom(ex, as) && PL_domain_error("as", ex);
211 }
212
213 if ( get_event_listp(type, &listp, &argc PASS_LD) )
214 return register_event_hook(listp, as == ATOM_last, closure, argc);
215
216 return FALSE;
217 }
218
219 static
220 PRED_IMPL("prolog_listen", 2, prolog_listen, META)
221 { PRED_LD
222
223 return prolog_listen(A1, A2, 0 PASS_LD);
224 }
225
226 static
227 PRED_IMPL("prolog_listen", 3, prolog_listen, META)
228 { PRED_LD
229
230 return prolog_listen(A1, A2, A3 PASS_LD);
231 }
232
233
234 static
235 PRED_IMPL("prolog_unlisten", 2, prolog_unlisten, 0)
236 { PRED_LD
237 event_list **listp;
238 size_t argc;
239
240 if ( get_event_listp(A1, &listp, &argc PASS_LD) )
241 { event_list *list;
242
243 if ( (list = *listp) )
244 { Module m = NULL;
245 term_t t = PL_new_term_ref();
246 atom_t name = 0;
247 event_callback *ev, *next, *prev = NULL;
248 fid_t fid = PL_open_foreign_frame();
249 term_t tmp = PL_new_term_ref();
250 Procedure proc = NULL;
251
252 if ( !get_callback(A2, &m, t PASS_LD) )
253 return FALSE;
254 if ( PL_get_atom(t, &name) )
255 proc = resolveProcedure(PL_new_functor(name, argc), m);
256
257 LOCK_LIST(list);
258 for(ev = list->head; ev; ev = next)
259 { next = ev->next;
260
261 if ( !ev->function )
262 { if ( proc )
263 { if ( ev->procedure->definition == proc->definition )
264 { delete:
265 if ( prev )
266 { prev->next = ev->next;
267 } else
268 { list->head = ev->next;
269 if ( !list->head )
270 list->tail = NULL;
271 }
272 continue;
273 }
274 } else if ( ev->closure.term )
275 { if ( put_fastheap(ev->closure.term, tmp PASS_LD) &&
276 PL_unify(A2, tmp) )
277 goto delete;
278 if ( PL_exception(0) )
279 { UNLOCK_LIST(list);
280 return FALSE;
281 }
282 PL_rewind_foreign_frame(fid);
283 }
284 }
285
286 prev = ev;
287 }
288 UNLOCK_LIST(list);
289 }
290
291 return TRUE;
292 }
293
294 return FALSE;
295 }
296
297
298 int
register_event_function(event_list ** list,int last,int (* func)(),void * closure,int argc)299 register_event_function(event_list **list, int last, int (*func)(),
300 void *closure, int argc)
301 { event_callback *cb = PL_malloc(sizeof(*cb));
302 memset(cb, 0, sizeof(*cb));
303 cb->argc = argc;
304 cb->function = func;
305 cb->closure.pointer = closure;
306
307 return link_event(get_event_list(list), cb, last);
308 }
309
310
311 static void
free_event_callback(event_callback * cb)312 free_event_callback(event_callback *cb)
313 { if ( !cb->function && cb->closure.term )
314 free_fastheap(cb->closure.term);
315
316 PL_free(cb);
317 }
318
319 void
destroy_event_list(event_list ** listp)320 destroy_event_list(event_list **listp)
321 { event_list *list = *listp;
322
323 if ( list )
324 { event_callback *cb, *next;
325
326 *listp = NULL;
327 for(cb=list->head; cb; cb = next)
328 { next = cb->next;
329 free_event_callback(cb);
330 }
331 DELETE_LIST_LOCK(list);
332 PL_free(list);
333 }
334 }
335
336
337 static int
call_event_list(event_list * list,int argc,term_t argv ARG_LD)338 call_event_list(event_list *list, int argc, term_t argv ARG_LD)
339 { int rc = TRUE;
340
341 if ( list )
342 { event_callback *ev;
343
344 LOCK_LIST(list);
345 for(ev = list->head; ev; ev = ev->next)
346 { if ( ev->function )
347 { switch(argc)
348 { case 0:
349 rc = (*ev->function)(ev->closure.pointer);
350 break;
351 case 1:
352 rc = (*ev->function)(ev->closure.pointer, argv+1);
353 break;
354 case 2:
355 rc = (*ev->function)(ev->closure.pointer, argv+1, argv+2);
356 break;
357 default:
358 rc = FALSE;
359 assert(0);
360 }
361 } else if ( ev->closure.term )
362 { rc = rc &&
363 ( put_fastheap(ev->closure.term, argv PASS_LD) &&
364 PL_call_predicate(ev->module, PL_Q_NODEBUG|PL_Q_PASS_EXCEPTION,
365 ev->procedure, argv) );
366 } else
367 { assert(ev->argc == argc);
368 rc = rc && PL_call_predicate(NULL, PL_Q_NODEBUG|PL_Q_PASS_EXCEPTION,
369 ev->procedure, argv+1);
370 }
371 if ( !rc && PL_exception(0) )
372 break;
373 }
374 UNLOCK_LIST(list);
375 }
376
377 return rc;
378 }
379
380
381 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
382 callEventHook() is used to call Prolog in debugger related events that
383 happen in the system. In some cases, these events are generated while
384 the system holds locks. Such code should call delayEvents() and
385 sendDelayedEvents(). These calls must be properly nested. Delaying is
386 currently only implemented for PLEV_BREAK and PLEV_NOBREAK.
387 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
388
389 typedef struct delayed_event
390 { pl_event_type type; /* PLEV_* */
391 union
392 { struct
393 { Clause clause;
394 int offset;
395 } pc;
396 struct
397 { Clause clause;
398 } clause;
399 struct
400 { Procedure proc;
401 } proc;
402 } value;
403 } delayed_event;
404
405
406 static int
delayEvent(pl_event_type ev,va_list args)407 delayEvent(pl_event_type ev, va_list args)
408 { GET_LD
409
410 if ( LD->event.buffered )
411 { delayed_event dev;
412
413 dev.type = ev;
414
415 switch(ev)
416 { case PLEV_BREAK_EXISTS:
417 case PLEV_BREAK:
418 case PLEV_NOBREAK:
419 case PLEV_GCNOBREAK:
420 dev.value.pc.clause = va_arg(args, Clause);
421 dev.value.pc.offset = va_arg(args, int);
422 acquire_clause(dev.value.pc.clause);
423 break;
424 case PLEV_ERASED_CLAUSE:
425 dev.value.clause.clause = va_arg(args, Clause);
426 acquire_clause(dev.value.pc.clause);
427 break;
428 case PLEV_UNTABLE:
429 dev.value.proc.proc = va_arg(args, Procedure);
430 break;
431 default:
432 assert(0);
433 }
434
435 addBuffer(LD->event.buffered, dev, delayed_event);
436 }
437
438 return TRUE;
439 }
440
441
442 int
delayEvents(void)443 delayEvents(void)
444 { GET_LD
445
446 if ( !LD->event.delay_nesting++ )
447 { assert(!LD->event.buffered);
448
449 if ( (LD->event.buffered = malloc(sizeof(tmp_buffer))) )
450 { initBuffer(LD->event.buffered);
451 return TRUE;
452 }
453 }
454
455 return FALSE;
456 }
457
458
459 /* Returns
460 -1: an exception occurred while sending events
461 N: number of events sent
462 */
463
464 int
sendDelayedEvents(int noerror)465 sendDelayedEvents(int noerror)
466 { GET_LD
467 int sent = 0;
468
469 if ( --LD->event.delay_nesting == 0 )
470 { Buffer b = LD->event.buffered;
471 delayed_event *dev = baseBuffer(b, delayed_event);
472 int count = entriesBuffer(b, delayed_event);
473
474 LD->event.buffered = NULL;
475
476 for(; count-- > 0; dev++)
477 { if ( noerror )
478 { switch(dev->type)
479 { case PLEV_BREAK_EXISTS:
480 case PLEV_BREAK:
481 case PLEV_NOBREAK:
482 case PLEV_GCNOBREAK:
483 noerror = callEventHook(dev->type,
484 dev->value.pc.clause, dev->value.pc.offset);
485 sent++;
486 release_clause(dev->value.pc.clause);
487 break;
488 case PLEV_ERASED_CLAUSE:
489 noerror = callEventHook(dev->type, dev->value.clause.clause);
490 sent++;
491 release_clause(dev->value.pc.clause);
492 break;
493 case PLEV_UNTABLE:
494 noerror = callEventHook(dev->type, dev->value.proc.proc);
495 sent++;
496 break;
497 default:
498 assert(0);
499 }
500 }
501 }
502
503 discardBuffer(b);
504 free(b);
505 }
506
507 return noerror ? sent : -1;
508 }
509
510
511 int
PL_call_event_hook(pl_event_type ev,...)512 PL_call_event_hook(pl_event_type ev, ...)
513 { event_list **listp = event_list_location(ev);
514
515 if ( *listp && GD->cleaning != CLN_DATA )
516 { va_list args;
517 int rc;
518
519 va_start(args, ev);
520 rc = PL_call_event_hook_va(ev, args);
521 va_end(args);
522
523 return rc;
524 }
525
526 return TRUE;
527 }
528
529
530 /* Returns FALSE iff there is an exception inside the execution of the
531 * hook
532 */
533
534 int
PL_call_event_hook_va(pl_event_type ev,va_list args)535 PL_call_event_hook_va(pl_event_type ev, va_list args)
536 { GET_LD
537 wakeup_state wstate;
538 int rc = TRUE;
539 event_list *list = *event_list_location(ev);
540 term_t av;
541 const event_type *event_decl = &PL_events[ev];
542
543 if ( LD->event.delay_nesting )
544 { delayEvent(ev, args);
545 return TRUE;
546 }
547
548 if ( !saveWakeup(&wstate, TRUE PASS_LD) )
549 return FALSE;
550 av = PL_new_term_refs(event_decl->argc+1);
551
552 switch(ev)
553 { case PLEV_ABORT:
554 break;
555 case PLEV_ERASED_CLAUSE:
556 { Clause cl = va_arg(args, Clause); /* object erased */
557
558 rc = PL_put_clref(av+1, cl);
559 break;
560 }
561 case PLEV_ERASED_RECORD:
562 { RecordRef r = va_arg(args, RecordRef); /* object erased */
563
564 rc = PL_unify_recref(av+1, r);
565 break;
566 }
567 case PLEV_BREAK:
568 case PLEV_BREAK_EXISTS:
569 case PLEV_NOBREAK:
570 case PLEV_GCNOBREAK:
571 { Clause cl = va_arg(args, Clause);
572 int offset = va_arg(args, int);
573
574 rc = ( PL_put_atom(av+1,
575 ev == PLEV_BREAK ? ATOM_true :
576 ev == PLEV_NOBREAK ? ATOM_false :
577 ev == PLEV_GCNOBREAK ? ATOM_gc :
578 ATOM_exist) &&
579 PL_put_clref(av+2, cl) &&
580 PL_put_intptr(av+3, offset) );
581 break;
582 }
583 case PLEV_FRAMEFINISHED:
584 { LocalFrame fr = va_arg(args, LocalFrame);
585
586 rc = PL_put_frame(av+1, fr);
587 break;
588 }
589 #ifdef O_PLMT
590 case PLEV_THREAD_EXIT:
591 { PL_thread_info_t *info = va_arg(args, PL_thread_info_t*);
592
593 rc = unify_thread_id(av+1, info);
594 break;
595 }
596 case PLEV_THIS_THREAD_EXIT:
597 break;
598 #endif
599 case PLEV_UNTABLE:
600 { Procedure proc = va_arg(args, Procedure);
601 rc = unify_definition(NULL, av+1, proc->definition,
602 0, GP_QUALIFY|GP_NAMEARITY);
603 break;
604 }
605 default:
606 rc = warning("callEventHook(): unknown event: %d", ev);
607 goto out;
608 }
609
610 if ( rc )
611 { rc = call_event_list(list, event_decl->argc, av PASS_LD);
612
613 if ( !rc && PL_exception(0) )
614 set(&wstate, WAKEUP_KEEP_URGENT_EXCEPTION);
615 else
616 rc = TRUE; /* only FALSE on error */
617 }
618
619 out:
620 restoreWakeup(&wstate PASS_LD);
621
622 return rc;
623 }
624
625
626 int
predicate_update_event(Definition def,atom_t action,Clause cl ARG_LD)627 predicate_update_event(Definition def, atom_t action, Clause cl ARG_LD)
628 { wakeup_state wstate;
629 term_t av;
630 int rc = TRUE;
631
632 if ( !saveWakeup(&wstate, TRUE PASS_LD) )
633 return FALSE;
634 av = PL_new_term_refs(3); /* closure, action, clause */
635 if ( !PL_put_atom(av+1, action) ||
636 !PL_put_clref(av+2, cl) )
637 return FALSE;
638
639 rc = call_event_list(def->events, 2, av PASS_LD);
640
641 restoreWakeup(&wstate PASS_LD);
642
643 return rc;
644 }
645
646 int
retractall_event(Definition def,term_t head,functor_t start ARG_LD)647 retractall_event(Definition def, term_t head, functor_t start ARG_LD)
648 { wakeup_state wstate;
649 term_t av;
650 int rc = TRUE;
651
652 if ( !saveWakeup(&wstate, TRUE PASS_LD) )
653 return FALSE;
654 av = PL_new_term_refs(4); /* closure, action, start/end, head */
655
656 if ( !PL_put_atom(av+1, def->module->name) ||
657 !PL_put_term(av+2, head) ||
658 !PL_cons_functor_v(av+2, FUNCTOR_colon2, av+1) ||
659 !PL_cons_functor_v(av+2, start, av+2) ||
660 !PL_put_atom(av+1, ATOM_retractall) )
661 return FALSE;
662
663 rc = call_event_list(def->events, 2, av PASS_LD);
664
665 restoreWakeup(&wstate PASS_LD);
666
667 return rc;
668 }
669
670
671
672 /*******************************
673 * PUBLISH PREDICATES *
674 *******************************/
675
676 #define META PL_FA_TRANSPARENT
677
678 BeginPredDefs(event)
679 PRED_DEF("prolog_listen", 2, prolog_listen, META)
680 PRED_DEF("prolog_listen", 3, prolog_listen, META)
681 PRED_DEF("prolog_unlisten", 2, prolog_unlisten, META)
682 EndPredDefs
683