YAP 7.1.0
gprof.c
1/*************************************************************************
2* *
3* YAP Prolog *
4* *
5* Yap Prolog was developed at NCCUP - Universidade do Porto *
6* *
7* Copyright R. Lopes,L.Damas, V. Santos Costa and Universidade do Porto 1985-- *
8* *
9**************************************************************************
10* *
11* File: gprof.c *
12* comments: Interrupt Driven Profiler *
13* *
14* Last rev: $Date: 2008-03-26 14:37:07 $,$Author: vsc $ *
15* $Log: not supported by cvs2svn $
16* Revision 1.9 2007/10/08 23:02:15 vsc
17* minor fixes
18*
19* Revision 1.8 2007/04/10 22:13:20 vsc
20* fix max modules limitation
21*
22* Revision 1.7 2006/08/22 16:12:45 vsc
23* global variables
24*
25* Revision 1.6 2006/08/07 18:51:44 vsc
26* fix garbage collector not to try to garbage collect when we ask for large
27* chunks of stack in a single go.
28*
29* Revision 1.5 2006/04/27 20:58:59 rslopes
30* fix do profiler offline.
31*
32* Revision 1.4 2006/02/01 13:28:56 vsc
33* bignum support fixes
34*
35* Revision 1.3 2006/01/17 14:10:40 vsc
36* YENV may be an HW register (breaks some tabling code)
37* All YAAM instructions are now brackedted, so Op introduced an { and EndOp introduces an }. This is because Ricardo assumes that.
38* Fix attvars when COROUTING is undefined.
39*
40* Revision 1.2 2005/12/23 00:20:13 vsc
41* updates to gprof
42* support for __POWER__
43* Try to saveregs before longjmp.
44*
45* Revision 1.1 2005/12/17 03:26:38 vsc
46* move event profiler outside from stdpreds.c
47* *
48*************************************************************************/
49
50
85#ifdef SCCS
86static char SccsId[] = "%W% %G%";
87#endif
88
89#if defined(__x86_64__) && defined (__linux__)
90
91#define __USE_GNU
92
93#include <ucontext.h>
94
95typedef greg_t context_reg;
96#define CONTEXT_PC(scv) (((ucontext_t *)(scv))->uc_mcontext.gregs[14])
97#define CONTEXT_BP(scv) (((ucontext_t *)(scv))->uc_mcontext.gregs[6])
98
99#elif defined(__i386__) && defined (__linux__)
100
101
102#include <ucontext.h>
103
104typedef greg_t context_reg;
105#define CONTEXT_PC(scv) (((ucontext_t *)(scv))->uc_mcontext.gregs[14])
106#define CONTEXT_BP(scv) (((ucontext_t *)(scv))->uc_mcontext.gregs[6])
107
108#elif defined(__APPLE__) && defined(__x86_64__)
109
110#include <AvailabilityMacros.h>
111#include <sys/ucontext.h>
112
113#if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5
114#define CONTEXT_REG(r) r
115#else
116#define CONTEXT_REG(r) __##r
117#endif
118
119#define CONTEXT_STATE(scv) (((ucontext_t *)(scv))->uc_mcontext->CONTEXT_REG(ss))
120#define CONTEXT_PC(scv) (CONTEXT_STATE(scv).CONTEXT_REG(rip))
121#define CONTEXT_BP(scv) (CONTEXT_STATE(scv).CONTEXT_REG(rbp))
122
123#elif defined(__APPLE__) && defined(__i386__)
124
125#include <AvailabilityMacros.h>
126#include <sys/ucontext.h>
127
128#if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5
129#define CONTEXT_REG(r) r
130#else
131#define CONTEXT_REG(r) __##r
132#endif
133
134#define CONTEXT_STATE(scv) (((ucontext_t *)(scv))->uc_mcontext->CONTEXT_REG(ss))
135#define CONTEXT_PC(scv) (CONTEXT_STATE(scv).CONTEXT_REG(eip))
136#define CONTEXT_BP(scv) (CONTEXT_STATE(scv).CONTEXT_REG(ebp))
137#define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
138
139#else
140
141#define CONTEXT_PC(scv) NULL
142#define CONTEXT_BP(scv) NULL
143#ifdef LOW_PROF
144#undef LOW_PROF
145#endif
146
147#endif
148
149#include "absmi.h"
150#include <stdio.h>
151
152#if HAVE_STRING_H
153#include <string.h>
154#endif
155
156#ifdef LOW_PROF
157#include <signal.h>
158#include <unistd.h>
159#include <sys/time.h>
160#ifdef __APPLE__
161#else
162#ifdef UCONTEXT_H
163#include <ucontext.h>
164#endif
165#endif
166
167
168
169#define TIMER_DEFAULT 100
170#define PROFILING_FILE 1
171#define PROFPREDS_FILE 2
172
173typedef struct {
174 char tag;
175 void *ptr;
176} __attribute__ ((packed)) buf_ptr;
177
178typedef struct {
179 gprof_info inf;
180 void *end;
181 PredEntry *pe;
182} __attribute__ ((packed)) buf_extra;
183
184typedef struct RB_red_blk_node {
185 yamop *key; /* first address */
186 yamop *lim; /* end address */
187 PredEntry *pe; /* parent predicate */
188 gprof_info source; /* how block was allocated */
189 UInt pcs; /* counter with total for each clause */
190 int red; /* if red=0 then the node is black */
191 struct RB_red_blk_node* left;
192 struct RB_red_blk_node* right;
193 struct RB_red_blk_node* parent;
195
196
197
198static rb_red_blk_node *
199RBMalloc(UInt size)
200{
201 return (rb_red_blk_node *)malloc(size);
202}
203
204static void
205RBfree(rb_red_blk_node *ptr)
206{
207 free((char *)ptr);
208}
209
210static rb_red_blk_node *
211RBTreeCreate(void) {
212 rb_red_blk_node* temp;
213
214 /* see the comment in the rb_red_blk_tree structure in red_black_tree.h */
215 /* for information on nil and root */
216 temp=GLOBAL_ProfilerNil= RBMalloc(sizeof(rb_red_blk_node));
217 temp->parent=temp->left=temp->right=temp;
218 temp->pcs=0;
219 temp->red=0;
220 temp->key=temp->lim=NULL;
221 temp->pe=NULL;
222 temp->source=GPROF_NO_EVENT;;
223 temp = RBMalloc(sizeof(rb_red_blk_node));
224 temp->parent=temp->left=temp->right=GLOBAL_ProfilerNil;
225 temp->key=temp->lim=NULL;
226 temp->pe=NULL;
227 temp->source=GPROF_NO_EVENT;
228 temp->pcs=0;
229 temp->red=0;
230 return temp;
231}
232
233/* This is code originally written by Emin Martinian */
234
235/***********************************************************************/
236/* FUNCTION: LeftRotate */
237
238/* INPUTS: This takes a tree so that it can access the appropriate */
239/* root and nil pointers, and the node to rotate on. */
240
241/* OUTPUT: None */
242
243/* Modifies Input: tree, x */
244
245/* EFFECTS: Rotates as described in _Introduction_To_Algorithms by */
246/* Cormen, Leiserson, Rivest (Chapter 14). Basically this */
247/* makes the parent of x be to the left of x, x the parent of */
248/* its parent before the rotation and fixes other pointers */
249/* accordingly. */
250/***********************************************************************/
251
252static void
253LeftRotate(rb_red_blk_node* x) {
255 rb_red_blk_node* rb_nil=GLOBAL_ProfilerNil;
256
257 /* I originally wrote this function to use the sentinel for */
258 /* nil to avoid checking for nil. However this introduces a */
259 /* very subtle bug because sometimes this function modifies */
260 /* the parent pointer of nil. This can be a problem if a */
261 /* function which calls LeftRotate also uses the nil sentinel */
262 /* and expects the nil sentinel's parent pointer to be unchanged */
263 /* after calling this function. For example, when RBDeleteFixUP */
264 /* calls LeftRotate it expects the parent pointer of nil to be */
265 /* unchanged. */
266
267 y=x->right;
268 x->right=y->left;
269
270 if (y->left != rb_nil) y->left->parent=x; /* used to use sentinel here */
271 /* and do an unconditional assignment instead of testing for nil */
272
273 y->parent=x->parent;
274
275 /* instead of checking if x->parent is the root as in the book, we */
276 /* count on the root sentinel to implicitly take care of this case */
277 if( x == x->parent->left) {
278 x->parent->left=y;
279 } else {
280 x->parent->right=y;
281 }
282 y->left=x;
283 x->parent=y;
284
285#ifdef DEBUG_ASSERT
286 Assert(!GLOBAL_ProfilerNil->red,"nil not red in LeftRotate");
287#endif
288}
289
290
291/***********************************************************************/
292/* FUNCTION: RighttRotate */
293
294/* INPUTS: This takes a tree so that it can access the appropriate */
295/* root and nil pointers, and the node to rotate on. */
296
297/* OUTPUT: None */
298
299/* Modifies Input?: tree, y */
300
301/* EFFECTS: Rotates as described in _Introduction_To_Algorithms by */
302/* Cormen, Leiserson, Rivest (Chapter 14). Basically this */
303/* makes the parent of x be to the left of x, x the parent of */
304/* its parent before the rotation and fixes other pointers */
305/* accordingly. */
306/***********************************************************************/
307
308static void
309RightRotate(rb_red_blk_node* y) {
311 rb_red_blk_node* rb_nil=GLOBAL_ProfilerNil;
312
313 /* I originally wrote this function to use the sentinel for */
314 /* nil to avoid checking for nil. However this introduces a */
315 /* very subtle bug because sometimes this function modifies */
316 /* the parent pointer of nil. This can be a problem if a */
317 /* function which calls LeftRotate also uses the nil sentinel */
318 /* and expects the nil sentinel's parent pointer to be unchanged */
319 /* after calling this function. For example, when RBDeleteFixUP */
320 /* calls LeftRotate it expects the parent pointer of nil to be */
321 /* unchanged. */
322
323 x=y->left;
324 y->left=x->right;
325
326 if (rb_nil != x->right) x->right->parent=y; /*used to use sentinel here */
327 /* and do an unconditional assignment instead of testing for nil */
328
329 /* instead of checking if x->parent is the root as in the book, we */
330 /* count on the root sentinel to implicitly take care of this case */
331 x->parent=y->parent;
332 if( y == y->parent->left) {
333 y->parent->left=x;
334 } else {
335 y->parent->right=x;
336 }
337 x->right=y;
338 y->parent=x;
339
340#ifdef DEBUG_ASSERT
341 Assert(!GLOBAL_ProfilerNil->red,"nil not red in RightRotate");
342#endif
343}
344
345/***********************************************************************/
346/* FUNCTION: TreeInsertHelp */
347
348/* INPUTS: tree is the tree to insert into and z is the node to insert */
349
350/* OUTPUT: none */
351
352/* Modifies Input: tree, z */
353
354/* EFFECTS: Inserts z into the tree as if it were a regular binary tree */
355/* using the algorithm described in _Introduction_To_Algorithms_ */
356/* by Cormen et al. This funciton is only intended to be called */
357/* by the RBTreeInsert function and not by the user */
358/***********************************************************************/
359
360static void
361TreeInsertHelp(rb_red_blk_node* z) {
362 /* This function should only be called by InsertRBTree (see above) */
365 rb_red_blk_node* rb_nil=GLOBAL_ProfilerNil;
366
367 z->left=z->right=rb_nil;
368 y=GLOBAL_ProfilerRoot;
369 x=GLOBAL_ProfilerRoot->left;
370 while( x != rb_nil) {
371 y=x;
372 if (x->key > z->key) { /* x.key > z.key */
373 x=x->left;
374 } else { /* x,key <= z.key */
375 x=x->right;
376 }
377 }
378 z->parent=y;
379 if ( (y == GLOBAL_ProfilerRoot) ||
380 (y->key > z->key)) { /* y.key > z.key */
381 y->left=z;
382 } else {
383 y->right=z;
384 }
385
386#ifdef DEBUG_ASSERT
387 Assert(!GLOBAL_ProfilerNil->red,"nil not red in TreeInsertHelp");
388#endif
389}
390
391/* Before calling Insert RBTree the node x should have its key set */
392
393/***********************************************************************/
394/* FUNCTION: RBTreeInsert */
395
396/* INPUTS: tree is the red-black tree to insert a node which has a key */
397/* pointed to by key and info pointed to by info. */
398
399/* OUTPUT: This function returns a pointer to the newly inserted node */
400/* which is guarunteed to be valid until this node is deleted. */
401/* What this means is if another data structure stores this */
402/* pointer then the tree does not need to be searched when this */
403/* is to be deleted. */
404
405/* Modifies Input: tree */
406
407/* EFFECTS: Creates a node node which contains the appropriate key and */
408/* info pointers and inserts it into the tree. */
409/***********************************************************************/
410
411static rb_red_blk_node *
412RBTreeInsert(yamop *key, yamop *lim) {
413 rb_red_blk_node * y;
414 rb_red_blk_node * x;
415 rb_red_blk_node * newNode;
416
417 x=(rb_red_blk_node*) RBMalloc(sizeof(rb_red_blk_node));
418 x->key=key;
419 x->lim=lim;
420
421 TreeInsertHelp(x);
422 newNode=x;
423 x->red=1;
424 while(x->parent->red) { /* use sentinel instead of checking for root */
425 if (x->parent == x->parent->parent->left) {
426 y=x->parent->parent->right;
427 if (y->red) {
428 x->parent->red=0;
429 y->red=0;
430 x->parent->parent->red=1;
431 x=x->parent->parent;
432 } else {
433 if (x == x->parent->right) {
434 x=x->parent;
435 LeftRotate(x);
436 }
437 x->parent->red=0;
438 x->parent->parent->red=1;
439 RightRotate(x->parent->parent);
440 }
441 } else { /* case for x->parent == x->parent->parent->right */
442 y=x->parent->parent->left;
443 if (y->red) {
444 x->parent->red=0;
445 y->red=0;
446 x->parent->parent->red=1;
447 x=x->parent->parent;
448 } else {
449 if (x == x->parent->left) {
450 x=x->parent;
451 RightRotate(x);
452 }
453 x->parent->red=0;
454 x->parent->parent->red=1;
455 LeftRotate(x->parent->parent);
456 }
457 }
458 }
459 GLOBAL_ProfilerRoot->left->red=0;
460 return newNode;
461
462#ifdef DEBUG_ASSERT
463 Assert(!GLOBAL_ProfilerNil->red,"nil not red in RBTreeInsert");
464 Assert(!GLOBAL_ProfilerRoot->red,"root not red in RBTreeInsert");
465#endif
466}
467
468/***********************************************************************/
469/* FUNCTION: RBExactQuery */
470
471/* INPUTS: tree is the tree to print and q is a pointer to the key */
472/* we are searching for */
473
474/* OUTPUT: returns the a node with key equal to q. If there are */
475/* multiple nodes with key equal to q this function returns */
476/* the one highest in the tree */
477
478/* Modifies Input: none */
479
480/***********************************************************************/
481
482static rb_red_blk_node*
483RBExactQuery(yamop* q) {
485 rb_red_blk_node* rb_nil=GLOBAL_ProfilerNil;
486
487 if (!GLOBAL_ProfilerRoot) return NULL;
488 x=GLOBAL_ProfilerRoot->left;
489 if (x == rb_nil) return NULL;
490 while(x->key != q) {/*assignemnt*/
491 if (x->key > q) { /* x->key > q */
492 x=x->left;
493 } else {
494 x=x->right;
495 }
496 if ( x == rb_nil) return NULL;
497 }
498 return(x);
499}
500
501
502static rb_red_blk_node*
503RBLookup(yamop *entry) {
504 rb_red_blk_node *current;
505
506 if (!GLOBAL_ProfilerRoot)
507 return NULL;
508 current = GLOBAL_ProfilerRoot->left;
509 while (current != GLOBAL_ProfilerNil) {
510 if (current->key <= entry && current->lim >= entry) {
511 return current;
512 }
513 if (entry > current->key)
514 current = current->right;
515 else
516 current = current->left;
517 }
518 return NULL;
519}
520
521
522/***********************************************************************/
523/* FUNCTION: RBDeleteFixUp */
524
525/* INPUTS: tree is the tree to fix and x is the child of the spliced */
526/* out node in RBTreeDelete. */
527
528/* OUTPUT: none */
529
530/* EFFECT: Performs rotations and changes colors to restore red-black */
531/* properties after a node is deleted */
532
533/* Modifies Input: tree, x */
534
535/* The algorithm from this function is from _Introduction_To_Algorithms_ */
536/***********************************************************************/
537
538static void RBDeleteFixUp(rb_red_blk_node* x) {
539 rb_red_blk_node* root=GLOBAL_ProfilerRoot->left;
541
542 while( (!x->red) && (root != x)) {
543 if (x == x->parent->left) {
544 w=x->parent->right;
545 if (w->red) {
546 w->red=0;
547 x->parent->red=1;
548 LeftRotate(x->parent);
549 w=x->parent->right;
550 }
551 if ( (!w->right->red) && (!w->left->red) ) {
552 w->red=1;
553 x=x->parent;
554 } else {
555 if (!w->right->red) {
556 w->left->red=0;
557 w->red=1;
558 RightRotate(w);
559 w=x->parent->right;
560 }
561 w->red=x->parent->red;
562 x->parent->red=0;
563 w->right->red=0;
564 LeftRotate(x->parent);
565 x=root; /* this is to exit while loop */
566 }
567 } else { /* the code below is has left and right switched from above */
568 w=x->parent->left;
569 if (w->red) {
570 w->red=0;
571 x->parent->red=1;
572 RightRotate(x->parent);
573 w=x->parent->left;
574 }
575 if ( (!w->right->red) && (!w->left->red) ) {
576 w->red=1;
577 x=x->parent;
578 } else {
579 if (!w->left->red) {
580 w->right->red=0;
581 w->red=1;
582 LeftRotate(w);
583 w=x->parent->left;
584 }
585 w->red=x->parent->red;
586 x->parent->red=0;
587 w->left->red=0;
588 RightRotate(x->parent);
589 x=root; /* this is to exit while loop */
590 }
591 }
592 }
593 x->red=0;
594
595#ifdef DEBUG_ASSERT
596 Assert(!tree->nil->red,"nil not black in RBDeleteFixUp");
597#endif
598}
599
600
601
602/***********************************************************************/
603/* FUNCTION: TreeSuccessor */
604
605/* INPUTS: tree is the tree in question, and x is the node we want the */
606/* the successor of. */
607
608/* OUTPUT: This function returns the successor of x or NULL if no */
609/* successor exists. */
610
611/* Modifies Input: none */
612
613/* Note: uses the algorithm in _Introduction_To_Algorithms_ */
614/***********************************************************************/
615
616static rb_red_blk_node*
617TreeSuccessor(rb_red_blk_node* x) {
619 rb_red_blk_node* rb_nil=GLOBAL_ProfilerNil;
620 rb_red_blk_node* root=GLOBAL_ProfilerRoot;
621
622 if (rb_nil != (y = x->right)) { /* assignment to y is intentional */
623 while(y->left != rb_nil) { /* returns the minium of the right subtree of x */
624 y=y->left;
625 }
626 return(y);
627 } else {
628 y=x->parent;
629 while(x == y->right) { /* sentinel used instead of checking for nil */
630 x=y;
631 y=y->parent;
632 }
633 if (y == root) return(rb_nil);
634 return(y);
635 }
636}
637
638/***********************************************************************/
639/* FUNCTION: RBDelete */
640
641/* INPUTS: tree is the tree to delete node z from */
642
643/* OUTPUT: none */
644
645/* EFFECT: Deletes z from tree and frees the key and info of z */
646/* using DestoryKey and DestoryInfo. Then calls */
647/* RBDeleteFixUp to restore red-black properties */
648
649/* Modifies Input: tree, z */
650
651/* The algorithm from this function is from _Introduction_To_Algorithms_ */
652/***********************************************************************/
653
654static void
655RBDelete(rb_red_blk_node* z){
658 rb_red_blk_node* rb_nil=GLOBAL_ProfilerNil;
659 rb_red_blk_node* root=GLOBAL_ProfilerRoot;
660
661 y= ((z->left == rb_nil) || (z->right == rb_nil)) ? z : TreeSuccessor(z);
662 x= (y->left == rb_nil) ? y->right : y->left;
663 if (root == (x->parent = y->parent)) { /* assignment of y->p to x->p is intentional */
664 root->left=x;
665 } else {
666 if (y == y->parent->left) {
667 y->parent->left=x;
668 } else {
669 y->parent->right=x;
670 }
671 }
672 if (y != z) { /* y should not be nil in this case */
673
674#ifdef DEBUG_ASSERT
675 Assert( (y!=tree->nil),"y is nil in RBDelete\n");
676#endif
677 /* y is the node to splice out and x is its child */
678
679 if (!(y->red)) RBDeleteFixUp(x);
680
681 /* tree->DestroyKey(z->key);*/
682 /*tree->DestroyInfo(z->info); */
683 y->left=z->left;
684 y->right=z->right;
685 y->parent=z->parent;
686 y->red=z->red;
687 z->left->parent=z->right->parent=y;
688 if (z == z->parent->left) {
689 z->parent->left=y;
690 } else {
691 z->parent->right=y;
692 }
693 RBfree(z);
694 } else {
695 /*tree->DestroyKey(y->key);*/
696 /*tree->DestroyInfo(y->info);*/
697 if (!(y->red)) RBDeleteFixUp(x);
698 RBfree(y);
699 }
700
701#ifdef DEBUG_ASSERT
702 Assert(!tree->nil->red,"nil not black in RBDelete");
703#endif
704}
705
706char *set_profile_dir(char *);
707char *set_profile_dir(char *name){
708 int size=0;
709
710 if (name!=NULL) {
711 size=strlen(name)+1;
712 if (GLOBAL_DIRNAME!=NULL) free(GLOBAL_DIRNAME);
713 GLOBAL_DIRNAME=malloc(size);
714 if (GLOBAL_DIRNAME==NULL) { printf("Profiler Out of Mem\n"); exit(1); }
715 strcpy(GLOBAL_DIRNAME,name);
716 }
717 if (GLOBAL_DIRNAME==NULL) {
718 do {
719 if (GLOBAL_DIRNAME!=NULL) free(GLOBAL_DIRNAME);
720 size+=20;
721 GLOBAL_DIRNAME=malloc(size);
722 if (GLOBAL_DIRNAME==NULL) { printf("Profiler Out of Mem\n"); exit(1); }
723 } while (getcwd(GLOBAL_DIRNAME, size-15)==NULL);
724 }
725
726return GLOBAL_DIRNAME;
727}
728
729char *profile_names(int);
730char *profile_names(int k) {
731 static char *FNAME=NULL;
732 int size=MAX_PATH;
733
734 if (GLOBAL_DIRNAME==NULL) set_profile_dir(NULL);
735 FNAME=malloc(size);
736 if (FNAME==NULL) { printf("Profiler Out of Mem\n"); exit(1); }
737
738 if (k==PROFILING_FILE) {
739 snprintf(FNAME,size,"%s/PROFILING_%d",GLOBAL_DIRNAME,getpid());
740 } else {
741 snprintf(FNAME,size,"%s/PROFPREDS_%d",GLOBAL_DIRNAME,getpid());
742 }
743 FNAME = realloc(FNAME, strlen(FNAME)+1);
744 // printf("%s\n",FNAME);
745 return FNAME;
746}
747
748void del_profile_files(void);
749void del_profile_files() {
750 if (GLOBAL_DIRNAME!=NULL) {
751 remove(profile_names(PROFPREDS_FILE));
752 remove(profile_names(PROFILING_FILE));
753 }
754}
755
756void
757Yap_inform_profiler_of_clause__(void *code_start, void *code_end, PredEntry *pe,gprof_info index_code) {
758 buf_ptr b;
759 buf_extra e;
760 GLOBAL_ProfOn = TRUE;
761 b.tag = '+';
762 b.ptr= code_start;
763 e.inf= index_code;
764 e.end= code_end;
765 e.pe= pe;
766 fwrite(&b,sizeof(b),1,GLOBAL_FPreds);
767 fwrite(&e,sizeof(e),1,GLOBAL_FPreds);
768 GLOBAL_ProfOn = FALSE;
769}
770
771typedef struct clause_entry {
772 yamop *beg, *end;
773 PredEntry *pp;
774 UInt pcs; /* counter with total for each clause */
775 UInt pca; /* counter with total for each predicate (repeated for each clause)*/
776 int ts; /* start end timestamp towards retracts, eventually */
777} clauseentry;
778
779static Int profend( USES_REGS1 );
780
781static void
782clean_tree(rb_red_blk_node* node) {
783 if (node == GLOBAL_ProfilerNil)
784 return;
785 clean_tree(node->left);
786 clean_tree(node->right);
787 Yap_FreeCodeSpace((char *)node);
788}
789
790static void
791reset_tree(void) {
792 clean_tree(GLOBAL_ProfilerRoot);
793 Yap_FreeCodeSpace((char *)GLOBAL_ProfilerNil);
794 GLOBAL_ProfilerNil = GLOBAL_ProfilerRoot = NULL;
795 GLOBAL_ProfCalls = GLOBAL_ProfGCs = GLOBAL_ProfHGrows = GLOBAL_ProfSGrows = GLOBAL_ProfMallocs = GLOBAL_ProfOns = 0L;
796}
797
798static int
799InitProfTree(void)
800{
801 if (GLOBAL_ProfilerRoot)
802 reset_tree();
803 while (!(GLOBAL_ProfilerRoot = RBTreeCreate())) {
804 if (!Yap_growheap(FALSE, 0, NULL)) {
805 Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing profiler");
806 return FALSE;
807 }
808 }
809 return TRUE;
810}
811
812static void RemoveCode(CODEADDR clau)
813{
814 rb_red_blk_node* x, *node;
815 PredEntry *pp;
816 UInt count;
817
818 if (!GLOBAL_ProfilerRoot) return;
819 if (!(x = RBExactQuery((yamop *)clau))) {
820 /* send message */
821 GLOBAL_ProfOn = FALSE;
822 return;
823 }
824 pp = x->pe;
825 count = x->pcs;
826 RBDelete(x);
827 /* use a single node to represent all deleted clauses */
828 if (!(node = RBExactQuery((yamop *)(pp->OpcodeOfPred)))) {
829 node = RBTreeInsert((yamop *)(pp->OpcodeOfPred), NEXTOP((yamop *)(pp->OpcodeOfPred),e));
830 node->lim = (yamop *)pp;
831 node->pe = pp;
832 node->pcs = count;
833 /* send message */
834 GLOBAL_ProfOn = FALSE;
835 return;
836 } else {
837 node->pcs += count;
838 }
839}
840
841static int
842showprofres( USES_REGS1 ) {
843 buf_ptr buf;
844
845 profend( PASS_REGS1 ); /* Make sure profiler has ended */
846
847 /* First part: Read information about predicates and store it on yap trail */
848
849 InitProfTree();
850 GLOBAL_ProfGCs=0;
851 GLOBAL_ProfMallocs=0;
852 GLOBAL_ProfHGrows=0;
853 GLOBAL_ProfSGrows=0;
854 GLOBAL_ProfIndexing=0;
855 GLOBAL_FProf=fopen(profile_names(PROFILING_FILE),"r");
856 if (GLOBAL_FProf==NULL) { fclose(GLOBAL_FProf); return FALSE; }
857 while (fread(&buf, sizeof(buf), 1, GLOBAL_FProf)) {
858 switch (buf.tag) {
859 case '+':
860 {
861 rb_red_blk_node *node;
862 buf_extra e;
863
864 if (fread(&e,sizeof(buf_extra),1,GLOBAL_FProf) == 0)
865 return FALSE;;
866 node = RBTreeInsert(buf.ptr, e.end);
867 node->pe = e.pe;
868 node->source = e.inf;
869 node->pcs = 0;
870 }
871 break;
872 case '?':
873 {
874 prolog_exec_mode md;
875
876 md = ((prolog_exec_mode*)buf.ptr)[0];
877 if (md & GCMode) {
878 GLOBAL_ProfGCs++;
879 } else if (md & MallocMode) {
880 GLOBAL_ProfMallocs++;
881 } else if (md & GrowHeapMode) {
882 GLOBAL_ProfHGrows++;
883 } else if (md & GrowStackMode) {
884 GLOBAL_ProfSGrows++;
885 }
886 }
887 break;
888 case '-':
889 RemoveCode(buf.ptr);
890 break;
891 default:
892 {
893 rb_red_blk_node *node;
894
895 node = RBLookup(buf.ptr);
896 if (!node) {
897#if DEBUG
898 fprintf(stderr,"Oops: %p\n", buf.ptr);
899#endif
900 } else {
901 switch(node->source) {
902 case GPROF_INDEX:
903 case GPROF_INDEX_EXPAND:
904 case GPROF_LU_INDEX:
905 case GPROF_STATIC_INDEX:
906 case GPROF_INIT_EXPAND:
907 case GPROF_INIT_LOG_UPD_CLAUSE:
908 case GPROF_NEW_LU_SWITCH:
909 case GPROF_NEW_STATIC_SWITCH:
910 case GPROF_NEW_EXPAND_BLOCK:
911 GLOBAL_ProfIndexing++;
912 break;
913 default:
914 break;
915 }
916 node->pcs++;
917 }
918 }
919 }
920 }
921 fclose(GLOBAL_FProf);
922 if (GLOBAL_ProfCalls==0)
923 return TRUE;
924 return TRUE;
925}
926
927
928#define TestMode (GCMode | GrowHeapMode | GrowStackMode | ErrorHandlingMode | InErrorMode | AbortMode | MallocMode)
929
930
931static void
932prof_alrm(int signo, siginfo_t *si, void *scv)
933{
934 CACHE_REGS
935 void * oldpc;
936 yamop *current_p;
937 buf_ptr b;
938
939 GLOBAL_ProfCalls++;
940 /* skip an interrupt */
941 if (GLOBAL_ProfOn) {
942 GLOBAL_ProfOns++;
943 return;
944 }
945 GLOBAL_ProfOn = TRUE;
946 oldpc = (void *) CONTEXT_PC(scv);
947 if (LOCAL_PrologMode & TestMode) {
948
949 b.tag = '?';
950 b.ptr= (void *)LOCAL_PrologMode;
951 fwrite(&b,sizeof(b),1,GLOBAL_FPreds);
952 GLOBAL_ProfOn = FALSE;
953 return;
954 }
955
956 if (oldpc>(void *) &Yap_absmi && oldpc <= (void *) &Yap_absmiEND) {
957 CACHE_REGS
958 /* we are running emulator code */
959#if BP_FREE
960 current_p =(yamop *) CONTEXT_BP(scv);
961#else
962 current_p = P;
963#endif
964 } else {
965 CACHE_REGS
966 op_numbers oop = Yap_op_from_opcode(PREVOP(P,Osbpp)->opc);
967
968 if (oop == _call_cpred || oop == _call_usercpred) {
969 /* doing C-code */
970 current_p = PREVOP(P,Osbpp)->y_u.Osbpp.p->CodeOfPred;
971 } else if ((oop = Yap_op_from_opcode(P->opc)) == _execute_cpred) {
972 /* doing C-code */
973 current_p = P->y_u.Osbpp.p->CodeOfPred;
974 } else {
975 current_p = P;
976 }
977 }
978
979#if !USE_SYSTEM_MALLOC
980 if (P < (yamop *)Yap_HeapBase || P > (yamop *)HeapTop) {
981#if DEBUG
982 fprintf(stderr,"Oops: %p, %p\n", oldpc, current_p);
983#endif
984 GLOBAL_ProfOn = FALSE;
985 return;
986 }
987#endif
988
989 b.tag = '.';
990 b.ptr= current_p;
991 fwrite(&b,sizeof(b),1,GLOBAL_FPreds);
992 GLOBAL_ProfOn = FALSE;
993}
994
995
996void
997Yap_InformOfRemoval(void *clau)
998{
999 GLOBAL_ProfOn = TRUE;
1000 if (GLOBAL_FPreds != NULL) {
1001 /* just store info about what is going on */
1002 buf_ptr b;
1003
1004 b.tag = '-';
1005 b.ptr= clau;
1006 fwrite(&b,sizeof(b),1,GLOBAL_FPreds);
1007 GLOBAL_ProfOn = FALSE;
1008 return;
1009 }
1010 GLOBAL_ProfOn = FALSE;
1011}
1012
1013static Int profend( USES_REGS1 );
1014
1015static Int
1016profnode( USES_REGS1 ) {
1017 Term t1 = Deref(ARG1), tleft, tright;
1018 rb_red_blk_node *node;
1019
1020 if (!GLOBAL_ProfilerRoot)
1021 return FALSE;
1022 if (!(node = (rb_red_blk_node *)IntegerOfTerm(t1)))
1023 node = GLOBAL_ProfilerRoot;
1024 /*
1025 if (node->key)
1026 fprintf(stderr,"%p: %p,%p,%d,%p(%d),%p,%p\n",node,node->key,node->lim,node->pcs,node->pe,node->pe->ArityOfPE,node->right,node->left);
1027 */
1028 if (node->left == GLOBAL_ProfilerNil) {
1029 tleft = TermNil;
1030 } else {
1031 tleft = MkIntegerTerm((Int)node->left);
1032 }
1033 if (node->left == GLOBAL_ProfilerNil) {
1034 tleft = TermNil;
1035 } else {
1036 tleft = MkIntegerTerm((Int)node->left);
1037 }
1038 if (node->right == GLOBAL_ProfilerNil) {
1039 tright = TermNil;
1040 } else {
1041 tright = MkIntegerTerm((Int)node->right);
1042 }
1043 return
1044 Yap_unify(ARG2,MkIntegerTerm((Int)node->key)) &&
1045 Yap_unify(ARG3,MkIntegerTerm((Int)node->pe)) &&
1046 Yap_unify(ARG4,MkIntegerTerm((Int)node->pcs)) &&
1047 Yap_unify(ARG5,tleft) &&
1048 Yap_unify(ARG6,tright);
1049}
1050
1051static Int
1052profglobs( USES_REGS1 ) {
1053 return
1054 Yap_unify(ARG1,MkIntegerTerm(GLOBAL_ProfCalls)) &&
1055 Yap_unify(ARG2,MkIntegerTerm(GLOBAL_ProfGCs)) &&
1056 Yap_unify(ARG3,MkIntegerTerm(GLOBAL_ProfHGrows)) &&
1057 Yap_unify(ARG4,MkIntegerTerm(GLOBAL_ProfSGrows)) &&
1058 Yap_unify(ARG5,MkIntegerTerm(GLOBAL_ProfMallocs)) &&
1059 Yap_unify(ARG6,MkIntegerTerm(GLOBAL_ProfIndexing)) &&
1060 Yap_unify(ARG7,MkIntegerTerm(GLOBAL_ProfOns)) ;
1061}
1062
1063static Int
1064do_profinit( USES_REGS1 )
1065{
1066 // GLOBAL_FPreds=fopen(profile_names(PROFPREDS_FILE),"w+");
1067 // if (GLOBAL_FPreds == NULL) return FALSE;
1068 GLOBAL_FProf=fopen(profile_names(PROFILING_FILE),"w+");
1069 if (GLOBAL_FProf==NULL) { fclose(GLOBAL_FProf); return FALSE; }
1070 GLOBAL_FPreds = GLOBAL_FProf;
1071
1072 Yap_dump_code_area_for_profiler();
1073 return TRUE;
1074}
1075
1076static Int profinit( USES_REGS1 )
1077{
1078 if (GLOBAL_ProfilerOn!=0) return (FALSE);
1079
1080 if (!do_profinit( PASS_REGS1 ))
1081 return FALSE;
1082
1083 GLOBAL_ProfilerOn = -1; /* Inited but not yet started */
1084 return(TRUE);
1085}
1086
1087static Int start_profilers(int msec)
1088{
1089 struct itimerval t;
1090 struct sigaction sa;
1091
1092 if (GLOBAL_ProfilerOn!=-1) {
1093 return FALSE; /* have to go through profinit */
1094 }
1095 sa.sa_sigaction=prof_alrm;
1096 sigemptyset(&sa.sa_mask);
1097 sa.sa_flags=SA_SIGINFO;
1098 if (sigaction(SIGPROF,&sa,NULL)== -1) return FALSE;
1099// if (signal(SIGPROF,prof_alrm) == SIG_ERR) return FALSE;
1100
1101 t.it_interval.tv_sec=0;
1102 t.it_interval.tv_usec=msec;
1103 t.it_value.tv_sec=0;
1104 t.it_value.tv_usec=msec;
1105 setitimer(ITIMER_PROF,&t,NULL);
1106
1107 GLOBAL_ProfilerOn = msec;
1108 return TRUE;
1109}
1110
1111
1112static Int profoff( USES_REGS1 ) {
1113 if (GLOBAL_ProfilerOn>0) {
1114 struct itimerval t;
1115 t.it_interval.tv_sec=0;
1116 t.it_interval.tv_usec=0;
1117 t.it_value.tv_sec=0;
1118 t.it_value.tv_usec=0;
1119
1120 setitimer(ITIMER_PROF,&t,NULL);
1121 GLOBAL_ProfilerOn = -1;
1122 return TRUE;
1123 }
1124 return FALSE;
1125}
1126
1127static Int ProfOn( USES_REGS1 ) {
1128 Term p;
1129 profoff( PASS_REGS1 );
1130 p=Deref(ARG1);
1131 return(start_profilers(IntOfTerm(p)));
1132}
1133
1134static Int ProfOn0( USES_REGS1 ) {
1135 profoff( PASS_REGS1 );
1136 return(start_profilers(TIMER_DEFAULT));
1137}
1138
1139static Int profison( USES_REGS1 ) {
1140 return (GLOBAL_ProfilerOn > 0);
1141}
1142
1143static Int profalt( USES_REGS1 ) {
1144 if (GLOBAL_ProfilerOn==0) return(FALSE);
1145 if (GLOBAL_ProfilerOn==-1) return ProfOn( PASS_REGS1 );
1146 return profoff( PASS_REGS1 );
1147}
1148
1149static Int profend( USES_REGS1 )
1150{
1151 if (GLOBAL_ProfilerOn==0) return(FALSE);
1152 profoff( PASS_REGS1 ); /* Make sure profiler is off */
1153 GLOBAL_ProfilerOn=0;
1154 fclose(GLOBAL_FProf);
1155 GLOBAL_FPreds = NULL;
1156 return TRUE;
1157}
1158
1159static Int getpredinfo( USES_REGS1 )
1160{
1161 PredEntry *pp = (PredEntry *)IntegerOfTerm(Deref(ARG1));
1162 Term mod, name;
1163 UInt arity;
1164
1165 if (!pp)
1166 return FALSE;
1167 if (pp->ModuleOfPred == PROLOG_MODULE)
1168 mod = TermProlog;
1169 else
1170 mod = pp->ModuleOfPred;
1171 if (pp->ModuleOfPred == IDB_MODULE) {
1172 if (pp->PredFlags & NumberDBPredFlag) {
1173 arity = 0;
1174 name = MkIntegerTerm(pp->src.IndxId);
1175 } else if (pp->PredFlags & AtomDBPredFlag) {
1176 arity = 0;
1177 name = MkAtomTerm((Atom)pp->FunctorOfPred);
1178 } else {
1179 name = MkAtomTerm(NameOfFunctor(pp->FunctorOfPred));
1180 arity = ArityOfFunctor(pp->FunctorOfPred);
1181 }
1182 } else {
1183 arity = pp->ArityOfPE;
1184 if (pp->ArityOfPE) {
1185 name = MkAtomTerm(NameOfFunctor(pp->FunctorOfPred));
1186 } else {
1187 name = MkAtomTerm((Atom)(pp->FunctorOfPred));
1188 }
1189 }
1190 return Yap_unify(ARG2, mod) &&
1191 Yap_unify(ARG3, name) &&
1192 Yap_unify(ARG4, MkIntegerTerm(arity));
1193}
1194
1195static Int profres0( USES_REGS1 ) {
1196 return(showprofres( PASS_REGS1 ));
1197}
1198
1199#endif /* LOW_PROF */
1200
1201void
1202Yap_InitLowProf(void)
1203{
1204#if LOW_PROF
1205 GLOBAL_ProfCalls = 0;
1206 GLOBAL_ProfilerOn = FALSE;
1207
1208 Yap_InitCPred("profinit",0, profinit, SafePredFlag);
1209 Yap_InitCPred("profend" ,0, profend, SafePredFlag);
1210 Yap_InitCPred("profon" , 0, ProfOn0, SafePredFlag);
1211 Yap_InitCPred("profoff", 0, profoff, SafePredFlag);
1212 Yap_InitCPred("profalt", 0, profalt, SafePredFlag);
1213 Yap_InitCPred("$offline_showprofres", 0, profres0, SafePredFlag);
1214 Yap_InitCPred("$profnode", 6, profnode, SafePredFlag);
1215 Yap_InitCPred("$profglobs", 7, profglobs, SafePredFlag);
1216 Yap_InitCPred("$profison",0 , profison, SafePredFlag);
1217 Yap_InitCPred("$get_pred_pinfo", 4, getpredinfo, SafePredFlag);
1218 Yap_InitCPred("showprofres", 4, getpredinfo, SafePredFlag);
1219#endif
1220}
1221
1222
@ source
If true maintain the source for all clauses.
Definition: YapGFlagInfo.h:601
Definition: Yatom.h:544
Definition: amidefs.h:264