From ecd2fab52e1e8729fa6357a93443b117eb26619f Mon Sep 17 00:00:00 2001 From: Vitor Santos Costa Date: Sun, 24 Oct 2010 22:19:03 +0200 Subject: [PATCH 01/10] fix term_variables/2 docs (obs from Bernd Gutmann). --- docs/yap.tex | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/docs/yap.tex b/docs/yap.tex index 0f57148b9..729fcb8e1 100644 --- a/docs/yap.tex +++ b/docs/yap.tex @@ -11614,15 +11614,6 @@ is considered. Otherwise, the term is considered only up to depth @code{1}, where the constants and the principal functor have depth @code{1}, and an argument of a term with depth @var{I} has depth @var{I+1}. -@item term_variables(?@var{Term}, -@var{Variables}) -@findex term_variables/2 -@syindex term_variables/2 -@cnindex term_variables/2 - -Unify @var{Variables} with the list of all variables of term -@var{Term}. The variables occur in the order of their first -appearance when traversing the term depth-first, left-to-right. - @item variables_within_term(+@var{Variables},?@var{Term}, -@var{OutputVariables}) @findex variables_within_term/3 @snindex variables_within_term/3 @@ -13286,6 +13277,16 @@ defined. @cnindex copy_term_nat/2 As @code{copy_term/2}. Attributes however, are @emph{not} copied but replaced by fresh variables. + +@item term_variables(?@var{Term}, -@var{Variables}) +@findex term_variables/2 +@syindex term_variables/2 +@cnindex term_variables/2 + +Unify @var{Variables} with the list of all variables of term +@var{Term}. The variables occur in the order of their first +appearance when traversing the term depth-first, left-to-right. + @end table @node Old Style Attribute Declarations, , New Style Attribute Declarations, Attributed Variables @@ -15712,12 +15713,11 @@ loop(Env) :- @section Profiling -The indexation mechanism restricts the set of clauses to be tried in a -procedure by using information about the status of a selected argument of -the goal (in YAP, as in most compilers, the first argument). -This argument -is then used as a key, selecting a restricted set of a clauses from all the -clauses forming the procedure. +The indexation mechanism restricts the set of clauses to be tried in a +procedure by using information about the status of the instantiated +arguments of the goal. These arguments are then used as a key, +selecting a restricted set of a clauses from all the clauses forming the +procedure. As an example, the two clauses for concatenate: From d0cd5f3fa3c44129b55623e3234a1864347ee1d0 Mon Sep 17 00:00:00 2001 From: Vitor Santos Costa Date: Tue, 26 Oct 2010 10:04:36 +0100 Subject: [PATCH 02/10] fix atom gc to actually recover first atom in the chain. --- C/agc.c | 1 + H/rheap.h | 2 +- H/sshift.h | 16 ++++++++++++++++ 3 files changed, 18 insertions(+), 1 deletion(-) diff --git a/C/agc.c b/C/agc.c index 9e0b78617..24e31e88b 100755 --- a/C/agc.c +++ b/C/agc.c @@ -126,6 +126,7 @@ AtomAdjust(Atom a) #define REINIT_LOCK(P) #define REINIT_RWLOCK(P) +#define NoAGCAtomAdjust(P) (P) #define OrArgAdjust(P) #define TabEntryAdjust(P) #define IntegerAdjust(D) (D) diff --git a/H/rheap.h b/H/rheap.h index f48cc246d..a4c978728 100755 --- a/H/rheap.h +++ b/H/rheap.h @@ -391,7 +391,7 @@ RestoreAtoms(void) PtoAtomHashEntryAdjust(Yap_heap_regs->hash_chain); HashPtr = HashChain; for (i = 0; i < AtomHashTableSize; ++i) { - HashPtr->Entry = AtomAdjust(HashPtr->Entry); + HashPtr->Entry = NoAGCAtomAdjust(HashPtr->Entry); RestoreAtomList(HashPtr->Entry); HashPtr++; } diff --git a/H/sshift.h b/H/sshift.h index 44faebc8c..64a1f668c 100755 --- a/H/sshift.h +++ b/H/sshift.h @@ -320,6 +320,14 @@ AtomAdjust (Atom at) return (Atom) ((at)); } +inline EXTERN Atom NoAGCAtomAdjust (Atom); + +inline EXTERN Atom +NoAGCAtomAdjust (Atom at) +{ + return (Atom) ((at)); +} + inline EXTERN Prop PropAdjust (Prop); @@ -341,6 +349,14 @@ AtomAdjust (Atom at) return (Atom) ((at == NULL ? (at) : (Atom) (CharP (at) + HDiff))); } +inline EXTERN Atom NoAGCAtomAdjust (Atom); + +inline EXTERN Atom +NoAGCAtomAdjust (Atom at) +{ + return (Atom) ((at == NULL ? (at) : (Atom) (CharP (at) + HDiff))); +} + inline EXTERN Prop PropAdjust (Prop); From b22094283e497520e5a8c222728c99e0804fb139 Mon Sep 17 00:00:00 2001 From: Vitor Santos Costa Date: Tue, 26 Oct 2010 10:05:49 +0100 Subject: [PATCH 03/10] fix typo. --- C/dbase.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/C/dbase.c b/C/dbase.c index 8fafffcd1..b0af26266 100755 --- a/C/dbase.c +++ b/C/dbase.c @@ -34,7 +34,7 @@ static char SccsId[] = "%W% %G%"; /* There are two options to implement traditional immediate update semantics. - In the first option, we only remove an element of the chain when - it is phisically disposed of. This simplifies things, because + it is physically disposed of. This simplifies things, because pointers are always valid, but it complicates some stuff a bit: o You may have go through long lines of deleted db entries before you From a2e6a0157c31b71aa61c3a04161757f37013e716 Mon Sep 17 00:00:00 2001 From: Vitor Santos Costa Date: Tue, 26 Oct 2010 10:06:45 +0100 Subject: [PATCH 04/10] Use malloc to interfer less with normal memory allocation. --- C/gprof.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/C/gprof.c b/C/gprof.c index 6c46b8dec..6aaed9893 100755 --- a/C/gprof.c +++ b/C/gprof.c @@ -148,13 +148,13 @@ static rb_red_blk_node *ProfilerRoot, *ProfilerNil; static rb_red_blk_node * RBMalloc(UInt size) { - return (rb_red_blk_node *)Yap_AllocCodeSpace(size); + return (rb_red_blk_node *)malloc(size); } static void RBfree(rb_red_blk_node *ptr) { - Yap_FreeCodeSpace((char *)ptr); + free((char *)ptr); } static rb_red_blk_node * From ef53ed696b56f37f2a5408e26157238311ec6368 Mon Sep 17 00:00:00 2001 From: Vitor Santos Costa Date: Tue, 26 Oct 2010 10:07:34 +0100 Subject: [PATCH 05/10] allow uninstanted arguments in erased_statistics. --- pl/preds.yap | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/pl/preds.yap b/pl/preds.yap index 8b8789465..875dc1b81 100644 --- a/pl/preds.yap +++ b/pl/preds.yap @@ -877,8 +877,9 @@ predicate_statistics(P,NCls,Sz,ISz) :- '$predicate_statistics'(P,M,NCls,Sz,ISz) :- '$static_pred_statistics'(P,M,NCls,Sz,ISz). -predicate_erased_statistics(V,NCls,Sz,ISz) :- var(V), !, - '$do_error'(instantiation_error,predicate_statistics(V,NCls,Sz,ISz)). +predicate_erased_statistics(P,NCls,Sz,ISz) :- + current_predicate(_,P), + predicate_erased_statistics(P,NCls,Sz,ISz). predicate_erased_statistics(M:P,NCls,Sz,ISz) :- !, '$predicate_erased_statistics'(M:P,NCls,Sz,_,ISz). predicate_erased_statistics(P,NCls,Sz,ISz) :- From e0aa6ae30ad9591532f8d4ec8cd4f2f1099dc9f3 Mon Sep 17 00:00:00 2001 From: Vitor Santos Costa Date: Tue, 26 Oct 2010 22:01:29 +0100 Subject: [PATCH 06/10] improve low level profiler interface. Still doesn't work too well. --- C/cdmgr.c | 35 +++- C/gprof.c | 503 +++++++++++++++++++----------------------------------- 2 files changed, 208 insertions(+), 330 deletions(-) diff --git a/C/cdmgr.c b/C/cdmgr.c index 228ee2f2a..17128c49d 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -200,7 +200,7 @@ * Revision 1.174 2005/12/23 00:20:13 vsc * updates to gprof * support for __POWER__ -* Try to saveregs before longjmp. +* Try to saveregs before _longjmp. * * Revision 1.173 2005/12/17 03:25:39 vsc * major changes to support online event-based profiling @@ -5169,6 +5169,31 @@ p_continue_static_clause(void) #if LOW_PROF +static void +add_code_in_lu_index(LogUpdIndex *cl, PredEntry *pp) +{ + char *code_end = (char *)cl + cl->ClSize; + Yap_inform_profiler_of_clause(cl->ClCode, (yamop *)code_end, pp,0); + cl = cl->ChildIndex; + while (cl != NULL) { + add_code_in_lu_index(cl, pp); + cl = cl->SiblingIndex; + } +} + +static void +add_code_in_static_index(StaticIndex *cl, PredEntry *pp) +{ + char *code_end = (char *)cl + cl->ClSize; + Yap_inform_profiler_of_clause(cl->ClCode, (yamop *)code_end, pp,0); + cl = cl->ChildIndex; + while (cl != NULL) { + add_code_in_static_index(cl, pp); + cl = cl->SiblingIndex; + } +} + + static void add_code_in_pred(PredEntry *pp) { yamop *clcode; @@ -5192,15 +5217,13 @@ add_code_in_pred(PredEntry *pp) { Yap_inform_profiler_of_clause((yamop *)&(pp->cs.p_code.ExpandCode), (yamop *)(&(pp->cs.p_code.ExpandCode)+1), pp, 1); clcode = pp->cs.p_code.TrueCodeOfPred; if (pp->PredFlags & IndexedPredFlag) { - char *code_end; if (pp->PredFlags & LogUpdatePredFlag) { LogUpdIndex *cl = ClauseCodeToLogUpdIndex(clcode); - code_end = (char *)cl + cl->ClSize; + add_code_in_lu_index(cl, pp); } else { StaticIndex *cl = ClauseCodeToStaticIndex(clcode); - code_end = (char *)cl + cl->ClSize; + add_code_in_static_index(cl, pp); } - Yap_inform_profiler_of_clause(clcode, (yamop *)code_end, pp,0); } clcode = pp->cs.p_code.FirstClause; if (clcode != NULL) { @@ -5232,7 +5255,7 @@ add_code_in_pred(PredEntry *pp) { code_end = (char *)cl + cl->ClSize; Yap_inform_profiler_of_clause(cl->ClCode, (yamop *)code_end, pp,0); - if (cl->ClCode == pp->cs.p_code.FirstClause) + if (cl->ClCode == pp->cs.p_code.LastClause) break; cl = cl->ClNext; } while (TRUE); diff --git a/C/gprof.c b/C/gprof.c index 6aaed9893..25d9405db 100755 --- a/C/gprof.c +++ b/C/gprof.c @@ -126,7 +126,6 @@ typedef greg_t context_reg; static Int ProfCalls, ProfGCs, ProfHGrows, ProfSGrows, ProfMallocs, ProfOn, ProfOns; #define TIMER_DEFAULT 100 -#define MORE_INFO_FILE 1 #define PROFILING_FILE 1 #define PROFPREDS_FILE 2 @@ -712,19 +711,10 @@ static Int order=0; ProfOn = TRUE; if (FPreds != NULL) { Int temp; + order++; if (index_code) temp=-order; else temp=order; - fprintf(FPreds,"+%p %p %p %ld",code_start,code_end, pe, (long int)temp); -#if MORE_INFO_FILE - if (pe->FunctorOfPred->KindOfPE==47872) { - if (pe->ArityOfPE) { - fprintf(FPreds," %s/%d", RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE); - } else { - fprintf(FPreds," %s",RepAtom((Atom)(pe->FunctorOfPred))->StrOfAE); - } - } -#endif - fprintf(FPreds,"\n"); + fprintf(FPreds,"+%p %p %p %ld\n",code_start,code_end, pe, (long int)temp); } ProfOn = FALSE; } @@ -737,228 +727,189 @@ typedef struct clause_entry { int ts; /* start end timestamp towards retracts, eventually */ } clauseentry; -static int -cl_cmp(const void *c1, const void *c2) -{ - const clauseentry *cl1 = (const clauseentry *)c1; - const clauseentry *cl2 = (const clauseentry *)c2; - if (cl1->beg > cl2->beg) return 1; - if (cl1->beg < cl2->beg) return -1; - return 0; +static Int profend(void); + +static void +clean_tree(rb_red_blk_node* node) { + if (node == ProfilerNil) + return; + clean_tree(node->left); + clean_tree(node->right); + Yap_FreeCodeSpace((char *)node); +} + +static void +reset_tree(void) { + clean_tree(ProfilerRoot); + Yap_FreeCodeSpace((char *)ProfilerNil); + ProfilerNil = ProfilerRoot = NULL; + ProfCalls = ProfGCs = ProfHGrows = ProfSGrows = ProfMallocs = ProfOns = 0L; } static int -p_cmp(const void *c1, const void *c2) +InitProfTree(void) { - const clauseentry *cl1 = (const clauseentry *)c1; - const clauseentry *cl2 = (const clauseentry *)c2; - if (cl1->pp > cl2->pp) return 1; - if (cl1->pp < cl2->pp) return -1; - - /* else same pp, but they are always different on the ts */ - if (cl1->ts > cl2->ts) return 1; - else return -1; + if (ProfilerRoot) + reset_tree(); + while (!(ProfilerRoot = RBTreeCreate())) { + if (!Yap_growheap(FALSE, 0, NULL)) { + Yap_Error(OUT_OF_HEAP_ERROR, TermNil, "while initialisating profiler"); + return FALSE; + } + } + return TRUE; } -static clauseentry * -search_pc_pred(yamop *pc_ptr,clauseentry *beg, clauseentry *end) { - Int i, j, f, l; - f = 0; l = (end-beg); - i = l/2; - while (TRUE) { - if (beg[i].beg > pc_ptr) { - l = i-1; - if (l < f) { - return NULL; - } - j = i; - i = (f+l)/2; - } else if (beg[i].end < pc_ptr) { - f = i+1; - if (f > l) { - return NULL; - } - i = (f+l)/2; - } else if (beg[i].beg <= pc_ptr && beg[i].end >= pc_ptr) { - return (&beg[i]); - } else { - return NULL; +static void LookupNode(yamop *current_p) { + rb_red_blk_node *node; + + if ((node = RBLookup(current_p))) { + node->pcs++; + return; + } else { + PredEntry *pp = NULL; + CODEADDR start, end; + + pp = Yap_PredEntryForCode(current_p, FIND_PRED_FROM_ANYWHERE, &start, &end); + if (!pp) { +#if DEBUG + fprintf(stderr,"lost %p, %d\n", P, Yap_op_from_opcode(P->opc)); +#endif + /* lost profiler event !! */ + return; } +#if !USE_SYSTEM_MALLOC + /* add this clause as new node to the tree */ + if (start < (CODEADDR)Yap_HeapBase || start > (CODEADDR)HeapTop || + end < (CODEADDR)Yap_HeapBase || end > (CODEADDR)HeapTop) { +#if DEBUG + fprintf(stderr,"Oops2: %p->%lu %p, %p\n", current_p, (unsigned long int)(current_p->opc), start, end); +#endif + return; + } +#endif + if (pp->ArityOfPE > 100) { +#if DEBUG + fprintf(stderr,"%p(%lu)-->%p\n",current_p,(unsigned long int)Yap_op_from_opcode(current_p->opc),pp); +#endif + return; + } + node = RBTreeInsert((yamop *)start, (yamop *)end); + node->pe = pp; + node->pcs = 1; } } -static Int profend(void); +static void RemoveCode(CODEADDR clau) +{ + rb_red_blk_node* x, *node; + PredEntry *pp; + UInt count; + + if (!ProfilerRoot) return; + if (!(x = RBExactQuery((yamop *)clau))) { + /* send message */ + ProfOn = FALSE; + return; + } + pp = x->pe; + count = x->pcs; + RBDelete(x); + /* use a single node to represent all deleted clauses */ + if (!(node = RBExactQuery((yamop *)(pp->OpcodeOfPred)))) { + node = RBTreeInsert((yamop *)(pp->OpcodeOfPred), NEXTOP((yamop *)(pp->OpcodeOfPred),e)); + node->lim = (yamop *)pp; + node->pe = pp; + node->pcs = count; + /* send message */ + ProfOn = FALSE; + return; + } else { + node->pcs += count; + } +} + +#define MAX_LINE_SIZE 1024 static int -showprofres(UInt type) { - clauseentry *pr, *t, *t2; - PredEntry *mype; - UInt count=0, ProfCalls=0, InGrowHeap=0, InGrowStack=0, InGC=0, InError=0, InUnify=0, InCCall=0; - yamop *pc_ptr,*y; void *oldpc; +showprofres(void) { + char line[MAX_LINE_SIZE]; + yamop *pr_beg, *pr_end; + PredEntry *pr_pp; + long int pr_count; + profend(); /* Make sure profiler has ended */ /* First part: Read information about predicates and store it on yap trail */ - FPreds=fopen(profile_names(PROFPREDS_FILE),"r"); - - if (FPreds == NULL) { printf("Sorry, profiler couldn't find PROFPREDS file. \n"); return FALSE; } - - ProfPreds=0; - pr=(clauseentry *) TR; - while (fscanf(FPreds,"+%p %p %p %d",&(pr->beg),&(pr->end),&(pr->pp),&(pr->ts)) > 0){ - int c; - pr->pcs = 0L; - pr++; - if (pr > (clauseentry *)Yap_TrailTop - 1024) { - Yap_growtrail(K64, FALSE); - } - ProfPreds++; - - do { - c=fgetc(FPreds); - } while(c!=EOF && c!='\n'); - } - fclose(FPreds); - if (ProfPreds==0) return(TRUE); - - qsort((void *)TR, ProfPreds, sizeof(clauseentry), cl_cmp); - - /* Second part: Read Profiling to know how many times each predicate has been profiled */ - + InitProfTree(); FProf=fopen(profile_names(PROFILING_FILE),"r"); - if (FProf==NULL) { printf("Sorry, profiler couldn't find PROFILING file. \n"); return FALSE; } + if (FProf==NULL) { fclose(FProf); return FALSE; } + while (fgets(line, MAX_LINE_SIZE, FProf) != NULL) { + if (line[0] == '+') { + rb_red_blk_node *node; + sscanf(line+1,"%p %p %p %ld",&pr_beg,&pr_end,&pr_pp,&pr_count); + node = RBTreeInsert(pr_beg, pr_end); + node->pe = pr_pp; + node->pcs = 0; + } else if (line[0] == '-') { + sscanf(line+1,"%p",&pr_beg); + RemoveCode((CODEADDR)pr_beg); + } else { + rb_red_blk_node *node; - t2=NULL; - ProfCalls=0; - while(fscanf(FProf,"%p %p %p\n",&oldpc, &pc_ptr,&mype) >0){ - if (type<10) ProfCalls++; - - if (oldpc!=0 && type<=2) { - if ((unsigned long)oldpc< 70000) { - if ((unsigned long) oldpc & GrowHeapMode) { InGrowHeap++; continue; } - if ((unsigned long)oldpc & GrowStackMode) { InGrowStack++; continue; } - if ((unsigned long)oldpc & GCMode) { InGC++; continue; } - if ((unsigned long)oldpc & (ErrorHandlingMode | InErrorMode)) { InError++; continue; } + sscanf(line,"%p",&pr_beg); + node = RBLookup(pr_beg); + if (!node) { +#if DEBUG + fprintf(stderr,"Oops: %p\n", pr_beg); +#endif + } else { + node->pcs++; } - if (oldpc>(void *) Yap_rational_tree_loop && oldpc<(void *) Yap_InitAbsmi) { InUnify++; continue; } - y=(yamop *) ((long) pc_ptr-20); - if (y->opc==Yap_opcode(_call_cpred) || y->opc==Yap_opcode(_call_usercpred)) { - InCCall++; /* I Was in a C Call */ - pc_ptr=y; - /* - printf("Aqui está um call_cpred(%p) \n",y->u.Osbpp.p->cs.f_code); - for(i=0;i<_std_top && pc_ptr->opc!=Yap_ABSMI_OPCODES[i];i++); - printf("Outro syscall diferente %s\n", Yap_op_names[i]); - */ - continue; - } - /* I should never get here, but since I'm, it is certanly Unknown Code, so - continue running to try to count it as Prolog Code */ } - - t=search_pc_pred(pc_ptr,(clauseentry *)TR,pr); - if (t!=NULL) { /* pc was found */ - if (type<10) t->pcs++; - else { - if (t->pp==(PredEntry *)type) { - ProfCalls++; - if (t2!=NULL) t2->pcs++; - } - } - t2=t; - } - } - fclose(FProf); - if (ProfCalls==0) return(TRUE); + if (ProfCalls==0) + return TRUE; + return TRUE; +} - /*I have the counting by clauses, but we also need them by predicate */ - qsort((void *)TR, ProfPreds, sizeof(clauseentry), p_cmp); - t = (clauseentry *)TR; - while (t < pr) { - UInt calls=t->pcs; +static Int +p_test(void) { + char line[MAX_LINE_SIZE]; + yamop *pr_beg, *pr_end; + PredEntry *pr_pp; + long int pr_count; - t2=t+1; - while(t2pp==t->pp) { - calls+=t2->pcs; - t2++; - } - while(tpca=calls; - t++; - } - } - /* counting done: now it is time to present the results */ - fflush(stdout); + profend(); /* Make sure profiler has ended */ - /* - if (type>10) { - PredEntry *myp = (PredEntry *)type; - if (myp->FunctorOfPred->KindOfPE==47872) { - printf("Details on predicate:"); - printf(" %s",RepAtom(AtomOfTerm(myp->ModuleOfPred))->StrOfAE); - printf(":%s",RepAtom(NameOfFunctor(myp->FunctorOfPred))->StrOfAE); - if (myp->ArityOfPE) printf("/%d\n",myp->ArityOfPE); - } - type=1; - } - */ + /* First part: Read information about predicates and store it on yap trail */ - if (type==0 || type==1 || type==3) { /* Results by predicate */ - t = (clauseentry *)TR; - while (t < pr) { - UInt calls=t->pca; - PredEntry *myp = t->pp; - - if (calls && myp->FunctorOfPred->KindOfPE==47872) { - count+=calls; - printf("%p",myp); - if (myp->ModuleOfPred) printf(" %s",RepAtom(AtomOfTerm(myp->ModuleOfPred))->StrOfAE); - printf(":%s",RepAtom(NameOfFunctor(myp->FunctorOfPred))->StrOfAE); - if (myp->ArityOfPE) printf("/%d",myp->ArityOfPE); - printf(" -> %lu (%3.1f%c)\n",(unsigned long int)calls,(float) calls*100/ProfCalls,'%'); - } - while (tpp == myp) t++; - } - } else { /* Results by clauses */ - t = (clauseentry *)TR; - while (t < pr) { - if (t->pca!=0 && (t->ts>=0 || t->pcs!=0) && t->pp->FunctorOfPred->KindOfPE==47872) { - UInt calls=t->pcs; - if (t->ts<0) { /* join all index entries */ - t2=t+1; - while(t2pp==t->pp && t2->ts<0) { - t++; - calls+=t->pcs; - t2++; - } - printf("IDX"); - } else { - printf(" "); - } - count+=calls; - // printf("%p %p",t->pp, t->beg); - if (t->pp->ModuleOfPred) printf(" %s",RepAtom(AtomOfTerm(t->pp->ModuleOfPred))->StrOfAE); - printf(":%s",RepAtom(NameOfFunctor(t->pp->FunctorOfPred))->StrOfAE); - if (t->pp->ArityOfPE) printf("/%d",t->pp->ArityOfPE); - printf(" -> %lu (%3.1f%c)\n",(unsigned long int)calls,(float) calls*100/ProfCalls,'%'); - } - t++; + InitProfTree(); + FProf=fopen("PROFILING_93920","r"); + if (FProf==NULL) { fclose(FProf); return FALSE; } + while (fgets(line, MAX_LINE_SIZE, FProf) != NULL) { + if (line[0] == '+') { + rb_red_blk_node *node; + sscanf(line+1,"%p %p %p %ld",&pr_beg,&pr_end,&pr_pp,&pr_count); + node = RBTreeInsert(pr_beg, pr_end); + node->pe = pr_pp; + node->pcs = 0; + } else if (line[0] == '-') { + sscanf(line+1,"%p",&pr_beg); + RemoveCode((CODEADDR)pr_beg); + } else { + rb_red_blk_node *node = RBTreeInsert(pr_beg, pr_end); + node->pe = pr_pp; + node->pcs = 1; } } - count=ProfCalls-(count+InGrowHeap+InGrowStack+InGC+InError+InUnify+InCCall); // Falta +InCCall - if (InGrowHeap>0) printf("%p sys: GrowHeap -> %lu (%3.1f%c)\n",(void *) GrowHeapMode,(unsigned long int)InGrowHeap,(float) InGrowHeap*100/ProfCalls,'%'); - if (InGrowStack>0) printf("%p sys: GrowStack -> %lu (%3.1f%c)\n",(void *) GrowStackMode,(unsigned long int)InGrowStack,(float) InGrowStack*100/ProfCalls,'%'); - if (InGC>0) printf("%p sys: GC -> %lu (%3.1f%c)\n",(void *) GCMode,(unsigned long int)InGC,(float) InGC*100/ProfCalls,'%'); - if (InError>0) printf("%p sys: ErrorHandling -> %lu (%3.1f%c)\n",(void *) ErrorHandlingMode,(unsigned long int)InError,(float) InError*100/ProfCalls,'%'); - if (InUnify>0) printf("%p sys: Unify -> %lu (%3.1f%c)\n",(void *) UnifyMode,(unsigned long int)InUnify,(float) InUnify*100/ProfCalls,'%'); - if (InCCall>0) printf("%p sys: C Code -> %lu (%3.1f%c)\n",(void *) CCallMode,(unsigned long int)InCCall,(float) InCCall*100/ProfCalls,'%'); - if (count>0) printf("Unknown:Unknown -> %lu (%3.1f%c)\n",(unsigned long int)count,(float) count*100/ProfCalls,'%'); - printf("Total of Calls=%lu \n",(unsigned long int)ProfCalls); - + fclose(FProf); + if (ProfCalls==0) + return TRUE; return TRUE; } @@ -970,17 +921,16 @@ static void prof_alrm(int signo, siginfo_t *si, void *scv) { void * oldpc=(void *) CONTEXT_PC(scv); - rb_red_blk_node *node = NULL; yamop *current_p; ProfCalls++; + /* skip an interrupt */ + if (ProfOn) { + ProfOns++; + return; + } + ProfOn = TRUE; if (Yap_PrologMode & TestMode) { - if (Yap_OffLineProfiler) { - fprintf(FProf,"%p %p\n", (void *) ((CELL)Yap_PrologMode & TestMode), P); - ProfOn = FALSE; - return; - } - if (Yap_PrologMode & GCMode) { ProfGCs++; ProfOn = FALSE; @@ -1034,60 +984,18 @@ prof_alrm(int signo, siginfo_t *si, void *scv) #if DEBUG fprintf(stderr,"Oops: %p, %p\n", oldpc, current_p); #endif + ProfOn = FALSE; return; } #endif if (Yap_OffLineProfiler) { - fprintf(FProf,"%p %p ", oldpc, current_p); - ProfOn = FALSE; - // return; - } - - if (ProfOn) { - ProfOns++; - return; - } - ProfOn = TRUE; - if ((node = RBLookup((yamop *)current_p))) { - node->pcs++; - if (Yap_OffLineProfiler) fprintf(FProf,"%p\n", node->pe); + fprintf(FProf,"%p\n", current_p); ProfOn = FALSE; return; - } else { - PredEntry *pp = NULL; - CODEADDR start, end; - - pp = Yap_PredEntryForCode(current_p, FIND_PRED_FROM_ANYWHERE, &start, &end); - if (Yap_OffLineProfiler) fprintf(FProf,"%p\n", pp); - if (!pp) { -#if DEBUG - fprintf(stderr,"lost %p, %d\n", P, Yap_op_from_opcode(P->opc)); -#endif - /* lost profiler event !! */ - ProfOn=FALSE; - return; - } -#if !USE_SYSTEM_MALLOC - /* add this clause as new node to the tree */ - if (start < (CODEADDR)Yap_HeapBase || start > (CODEADDR)HeapTop || - end < (CODEADDR)Yap_HeapBase || end > (CODEADDR)HeapTop) { -#if DEBUG - fprintf(stderr,"Oops2: %p->%lu %p, %p\n", current_p, (unsigned long int)(current_p->opc), start, end); -#endif - return; - } -#endif - if (pp->ArityOfPE > 100) { -#if DEBUG - fprintf(stderr,"%p:%p(%lu)-->%p\n",oldpc,current_p,(unsigned long int)Yap_op_from_opcode(current_p->opc),pp); -#endif - return; - } - node = RBTreeInsert((yamop *)start, (yamop *)end); - node->pe = pp; - node->pcs = 1; } + + LookupNode(current_p); ProfOn = FALSE; } @@ -1095,59 +1003,17 @@ prof_alrm(int signo, siginfo_t *si, void *scv) void Yap_InformOfRemoval(CODEADDR clau) { - rb_red_blk_node* x, *node; - UInt count; - PredEntry *pp; - - if (FPreds != NULL) { - /* ricardo? */ - /* do something */ - return; - } - if (!ProfilerRoot) return; ProfOn = TRUE; - if (!(x = RBExactQuery((yamop *)clau))) { - /* send message */ + if (FPreds != NULL) { + /* just store info about what is going on */ + fprintf(FPreds,"-%p\n",clau); ProfOn = FALSE; return; } - /* just keep within the other profiler for now */ - pp = x->pe; - count = x->pcs; - /* fprintf(stderr,"D %p:%p\n",x,pp); */ - RBDelete(x); - /* use a single node to represent all deleted clauses */ - if (!(node = RBExactQuery((yamop *)(pp->OpcodeOfPred)))) { - node = RBTreeInsert((yamop *)(pp->OpcodeOfPred), NEXTOP((yamop *)(pp->OpcodeOfPred),e)); - node->lim = (yamop *)pp; - node->pe = pp; - node->pcs = count; - /* send message */ - ProfOn = FALSE; - return; - } else { - node->pcs += count; - } + RemoveCode(clau); ProfOn = FALSE; } -static void -clean_tree(rb_red_blk_node* node) { - if (node == ProfilerNil) - return; - clean_tree(node->left); - clean_tree(node->right); - Yap_FreeCodeSpace((char *)node); -} - -static void -reset_tree(void) { - clean_tree(ProfilerRoot); - Yap_FreeCodeSpace((char *)ProfilerNil); - ProfilerNil = ProfilerRoot = NULL; - ProfCalls = ProfGCs = ProfHGrows = ProfSGrows = ProfMallocs = ProfOns = 0L; -} - static Int profend(void); static Int @@ -1201,21 +1067,15 @@ static Int do_profinit(void) { if (Yap_OffLineProfiler) { - FPreds=fopen(profile_names(PROFPREDS_FILE),"w+"); - if (FPreds == NULL) return FALSE; + // FPreds=fopen(profile_names(PROFPREDS_FILE),"w+"); + // if (FPreds == NULL) return FALSE; FProf=fopen(profile_names(PROFILING_FILE),"w+"); - if (FProf==NULL) { fclose(FPreds); return FALSE; } + if (FProf==NULL) { fclose(FProf); return FALSE; } + FPreds = FProf; Yap_dump_code_area_for_profiler(); } else { - if (ProfilerRoot) - reset_tree(); - while (!(ProfilerRoot = RBTreeCreate())) { - if (!Yap_growheap(FALSE, 0, NULL)) { - Yap_Error(OUT_OF_HEAP_ERROR, TermNil, "while initialisating profiler"); - return FALSE; - } - } + InitProfTree(); } return TRUE; } @@ -1330,7 +1190,9 @@ static Int profend(void) if (ProfilerOn==0) return(FALSE); profoff(); /* Make sure profiler is off */ ProfilerOn=0; - + if (Yap_OffLineProfiler) { + fclose(FProf); + } return TRUE; } @@ -1370,15 +1232,8 @@ static Int getpredinfo(void) Yap_unify(ARG4, MkIntegerTerm(arity)); } -static Int profres(void) { - Term p; - p=Deref(ARG1); - if (IsLongIntTerm(p)) return(showprofres(LongIntOfTerm(p))); - else return(showprofres(IntOfTerm(p))); -} - static Int profres0(void) { - return(showprofres(0)); + return(showprofres()); } #endif /* LOW_PROF */ @@ -1399,11 +1254,11 @@ Yap_InitLowProf(void) Yap_InitCPred("profoff", 0, profoff, SafePredFlag); Yap_InitCPred("profalt", 0, profalt, SafePredFlag); Yap_InitCPred("$offline_showprofres", 0, profres0, SafePredFlag); - Yap_InitCPred("$offline_showprofres", 1, profres, SafePredFlag); Yap_InitCPred("$profnode", 6, profnode, SafePredFlag); Yap_InitCPred("$profglobs", 6, profglobs, SafePredFlag); Yap_InitCPred("$profison",0 , profison, SafePredFlag); Yap_InitCPred("$get_pred_pinfo", 4, getpredinfo, SafePredFlag); Yap_InitCPred("showprofres", 4, getpredinfo, SafePredFlag); + Yap_InitCPred("prof_test", 0, p_test, 0); #endif } From b16a0d53b0db68224a613b9e39e0313d8970486d Mon Sep 17 00:00:00 2001 From: Vitor Santos Costa Date: Tue, 26 Oct 2010 22:02:23 +0100 Subject: [PATCH 07/10] integration of two different event profilers. --- pl/profile.yap | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/pl/profile.yap b/pl/profile.yap index af8df9a32..5121b5619 100644 --- a/pl/profile.yap +++ b/pl/profile.yap @@ -64,16 +64,11 @@ profile_reset :- fail. profile_reset. -showprofres :- - '$proftype'(offline), !, - '$offline_showprofres'. showprofres :- showprofres(-1). showprofres(A) :- - '$proftype'(offline), !, - '$offline_showprofres'(A). -showprofres(A) :- + ('$proftype'(offline) -> '$offline_showprofres' ; true), ('$profison' -> profoff, Stop = true ; Stop = false), '$profglobs'(Tot,GCs,HGrows,SGrows,Mallocs,ProfOns), % root node has no useful info. From ab8911708bf49cb796d68402132d7da6ac001bf3 Mon Sep 17 00:00:00 2001 From: Vitor Santos Costa Date: Tue, 26 Oct 2010 22:03:36 +0100 Subject: [PATCH 08/10] fix YAP to use _longjmp when available. longjmp is just too expensive on OSX machines. --- C/amasm.c | 42 +++++++++++------------ C/compiler.c | 92 +++++++++++++++++++++++++-------------------------- C/computils.c | 6 ++-- C/heapgc.c | 6 ++-- C/index.c | 52 ++++++++++++++--------------- C/iopreds.c | 6 ++-- C/parser.c | 10 +++--- H/Yap.h | 5 +++ config.h.in | 1 + configure | 40 ++++++++++++++++++++++ configure.in | 19 +++++++++++ 11 files changed, 172 insertions(+), 107 deletions(-) diff --git a/C/amasm.c b/C/amasm.c index 5fac347f3..c66965342 100755 --- a/C/amasm.c +++ b/C/amasm.c @@ -1480,7 +1480,7 @@ a_p(op_numbers opcode, clause_info *clinfo, yamop *code_p, int pass_no, struct i op = _p_equal; /* just to make some compilers happy */ Yap_Error(INTERNAL_COMPILER_ERROR, TermNil, "internal assembler error for built-in (%d)", (Flags & 0x7f)); save_machine_regs(); - longjmp(cip->CompilerBotch, 1); + _longjmp(cip->CompilerBotch, 1); } if (is_test) { UInt lab; @@ -1503,7 +1503,7 @@ a_p(op_numbers opcode, clause_info *clinfo, yamop *code_p, int pass_no, struct i Yap_Error(INTERNAL_COMPILER_ERROR, TermNil, "user defined predicate cannot be a test predicate"); save_machine_regs(); - longjmp(cip->CompilerBotch, 1); + _longjmp(cip->CompilerBotch, 1); } else code_p->opc = emit_op(_call_c_wfail); code_p->u.slp.s = @@ -2053,7 +2053,7 @@ a_try(op_numbers opcode, CELL lab, CELL opr, int nofalts, int hascut, yamop *cod if ((newcp = (yamop *)Yap_AllocCodeSpace(size)) == NULL) { /* OOOPS, got in trouble, must do a longjmp and recover space */ save_machine_regs(); - longjmp(cip->CompilerBotch,2); + _longjmp(cip->CompilerBotch,2); } Yap_LUIndexSpace_CP += size; #ifdef DEBUG @@ -2693,7 +2693,7 @@ a_f2(cmp_op_info *cmp_info, yamop *code_p, int pass_no, struct intermediates *ci case _plus: Yap_Error(INTERNAL_COMPILER_ERROR, cmp_info->x1_arg, "internal assembler error CX for +/2 (should be XC)"); save_machine_regs(); - longjmp(cip->CompilerBotch, 1); + _longjmp(cip->CompilerBotch, 1); break; case _minus: code_p->opc = emit_op(_p_minus_y_cv); @@ -2701,7 +2701,7 @@ a_f2(cmp_op_info *cmp_info, yamop *code_p, int pass_no, struct intermediates *ci case _times: Yap_Error(INTERNAL_COMPILER_ERROR, cmp_info->x1_arg, "internal assembler error CX for */2 (should be XC)"); save_machine_regs(); - longjmp(cip->CompilerBotch, 1); + _longjmp(cip->CompilerBotch, 1); break; case _div: code_p->opc = emit_op(_p_div_y_cv); @@ -2709,12 +2709,12 @@ a_f2(cmp_op_info *cmp_info, yamop *code_p, int pass_no, struct intermediates *ci case _and: Yap_Error(INTERNAL_COMPILER_ERROR, cmp_info->x1_arg, "internal assembler error CX for /\\/2 (should be XC)"); save_machine_regs(); - longjmp(cip->CompilerBotch, 1); + _longjmp(cip->CompilerBotch, 1); break; case _or: Yap_Error(INTERNAL_COMPILER_ERROR, cmp_info->x1_arg, "internal assembler error CX for \\//2 (should be XC)"); save_machine_regs(); - longjmp(cip->CompilerBotch, 1); + _longjmp(cip->CompilerBotch, 1); break; case _sll: code_p->opc = emit_op(_p_sll_y_cv); @@ -2744,7 +2744,7 @@ a_f2(cmp_op_info *cmp_info, yamop *code_p, int pass_no, struct intermediates *ci case _minus: Yap_Error(INTERNAL_COMPILER_ERROR, cmp_info->x2_arg, "internal assembler error XC for -/2"); save_machine_regs(); - longjmp(cip->CompilerBotch, 1); + _longjmp(cip->CompilerBotch, 1); break; case _times: code_p->opc = emit_op(_p_times_y_vc); @@ -2777,7 +2777,7 @@ a_f2(cmp_op_info *cmp_info, yamop *code_p, int pass_no, struct intermediates *ci case _arg: Yap_Error(INTERNAL_COMPILER_ERROR, cmp_info->x2_arg, "internal assembler error for arg/3"); save_machine_regs(); - longjmp(cip->CompilerBotch, 1); + _longjmp(cip->CompilerBotch, 1); break; case _functor: code_p->opc = emit_op(_p_func2s_y_vc); @@ -2838,7 +2838,7 @@ a_f2(cmp_op_info *cmp_info, yamop *code_p, int pass_no, struct intermediates *ci case _plus: Yap_Error(INTERNAL_COMPILER_ERROR, cmp_info->x1_arg, "internal assembler error CX for +/2"); save_machine_regs(); - longjmp(cip->CompilerBotch, 1); + _longjmp(cip->CompilerBotch, 1); break; case _minus: code_p->opc = emit_op(_p_minus_cv); @@ -2846,7 +2846,7 @@ a_f2(cmp_op_info *cmp_info, yamop *code_p, int pass_no, struct intermediates *ci case _times: Yap_Error(INTERNAL_COMPILER_ERROR, cmp_info->x1_arg, "internal assembler error CX for */2"); save_machine_regs(); - longjmp(cip->CompilerBotch, 1); + _longjmp(cip->CompilerBotch, 1); break; case _div: code_p->opc = emit_op(_p_div_cv); @@ -2854,12 +2854,12 @@ a_f2(cmp_op_info *cmp_info, yamop *code_p, int pass_no, struct intermediates *ci case _and: Yap_Error(INTERNAL_COMPILER_ERROR, cmp_info->x1_arg, "internal assembler error CX for /\\/2"); save_machine_regs(); - longjmp(cip->CompilerBotch, 1); + _longjmp(cip->CompilerBotch, 1); break; case _or: Yap_Error(INTERNAL_COMPILER_ERROR, cmp_info->x1_arg, "internal assembler error CX for \\//2"); save_machine_regs(); - longjmp(cip->CompilerBotch, 1); + _longjmp(cip->CompilerBotch, 1); break; case _sll: code_p->opc = emit_op(_p_sll_cv); @@ -2889,7 +2889,7 @@ a_f2(cmp_op_info *cmp_info, yamop *code_p, int pass_no, struct intermediates *ci case _minus: Yap_Error(INTERNAL_COMPILER_ERROR, cmp_info->x2_arg, "internal assembler error XC for -/2"); save_machine_regs(); - longjmp(cip->CompilerBotch, 1); + _longjmp(cip->CompilerBotch, 1); break; case _times: code_p->opc = emit_op(_p_times_vc); @@ -2922,7 +2922,7 @@ a_f2(cmp_op_info *cmp_info, yamop *code_p, int pass_no, struct intermediates *ci case _arg: Yap_Error(INTERNAL_COMPILER_ERROR, cmp_info->x2_arg, "internal assembler error for arg/3"); save_machine_regs(); - longjmp(cip->CompilerBotch, 1); + _longjmp(cip->CompilerBotch, 1); break; case _functor: code_p->opc = emit_op(_p_func2s_vc); @@ -3540,7 +3540,7 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp if (CellPtr(cip->label_offset+cip->cpc->rnd1) > ASP-256) { Yap_Error_Size = 256+((char *)(cip->label_offset+cip->cpc->rnd1) - (char *)H); save_machine_regs(); - longjmp(cip->CompilerBotch, 3); + _longjmp(cip->CompilerBotch, 3); } if ( (char *)(cip->label_offset+cip->cpc->rnd1) >= cip->freep) cip->freep = (char *)(cip->label_offset+(cip->cpc->rnd1+1)); @@ -3722,7 +3722,7 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp if (cip->cpc->nextInst->op != bccall_op) { Yap_Error(INTERNAL_COMPILER_ERROR, TermNil, "compiling binary test", (int) cip->cpc->op); save_machine_regs(); - longjmp(cip->CompilerBotch, 1); + _longjmp(cip->CompilerBotch, 1); } code_p = a_bfunc(cip->cpc->nextInst->rnd2, &clinfo, code_p, pass_no, cip); break; @@ -3762,7 +3762,7 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp default: Yap_Error(INTERNAL_COMPILER_ERROR, TermNil, "instruction %d found while assembling", (int) cip->cpc->op); save_machine_regs(); - longjmp(cip->CompilerBotch, 1); + _longjmp(cip->CompilerBotch, 1); } cip->cpc = cip->cpc->nextInst; } @@ -3788,7 +3788,7 @@ fetch_clause_space(Term* tp, UInt size, struct intermediates *cip, UInt *osizep) case OUT_OF_STACK_ERROR: Yap_Error_Size = 256+((char *)cip->freep - (char *)H); save_machine_regs(); - longjmp(cip->CompilerBotch,3); + _longjmp(cip->CompilerBotch,3); case OUT_OF_TRAIL_ERROR: /* don't just return NULL */ ARG1 = *tp; @@ -3865,7 +3865,7 @@ Yap_assemble(int mode, Term t, PredEntry *ap, int is_fact, struct intermediates Yap_LabelFirstArraySz = DEFAULT_NLABELS; if (!Yap_LabelFirstArray) { save_machine_regs(); - longjmp(cip->CompilerBotch, OUT_OF_HEAP_BOTCH); + _longjmp(cip->CompilerBotch, OUT_OF_HEAP_BOTCH); } } if (Yap_LabelFirstArray && max_label <= Yap_LabelFirstArraySz) { @@ -3874,7 +3874,7 @@ Yap_assemble(int mode, Term t, PredEntry *ap, int is_fact, struct intermediates cip->label_offset = (Int *)Yap_AllocCodeSpace(sizeof(Int)*max_label); if (!cip->label_offset) { save_machine_regs(); - longjmp(cip->CompilerBotch, OUT_OF_HEAP_BOTCH); + _longjmp(cip->CompilerBotch, OUT_OF_HEAP_BOTCH); } } } diff --git a/C/compiler.c b/C/compiler.c index 6e49a6e2c..dcd8ca7b1 100755 --- a/C/compiler.c +++ b/C/compiler.c @@ -533,7 +533,7 @@ optimize_ce(Term t, unsigned int arity, unsigned int level, compiler_struct *cgl if (H >= (CELL *)cglobs->cint.freep0) { /* oops, too many new variables */ save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); + _longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); } p->NextCE = cglobs->common_exps; cglobs->common_exps = p; @@ -568,7 +568,7 @@ compile_sf_term(Term t, int argno, int level) Yap_Error_Term = TermNil; Yap_ErrorMessage = "illegal argument of soft functor"; save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH); + _longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH); } else c_var(t, -argno, arity, level, cglobs); @@ -595,7 +595,7 @@ c_args(Term app, unsigned int level, compiler_struct *cglobs) Yap_Error_Term = TermNil; Yap_ErrorMessage = "exceed maximum arity of compiled goal"; save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH); + _longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH); } if (Arity > cglobs->max_args) cglobs->max_args = Arity; @@ -615,7 +615,7 @@ try_store_as_dbterm(Term t, Int argno, unsigned int arity, int level, compiler_s /* oops, too deep a term */ save_machine_regs(); Yap_Error_Size = 0; - longjmp(cglobs->cint.CompilerBotch, OUT_OF_AUX_BOTCH); + _longjmp(cglobs->cint.CompilerBotch, OUT_OF_AUX_BOTCH); } if (g < 16) return FALSE; @@ -626,18 +626,18 @@ try_store_as_dbterm(Term t, Int argno, unsigned int arity, int level, compiler_s switch(Yap_Error_TYPE) { case OUT_OF_STACK_ERROR: Yap_Error_TYPE = YAP_NO_ERROR; - longjmp(cglobs->cint.CompilerBotch,OUT_OF_STACK_BOTCH); + _longjmp(cglobs->cint.CompilerBotch,OUT_OF_STACK_BOTCH); case OUT_OF_TRAIL_ERROR: Yap_Error_TYPE = YAP_NO_ERROR; - longjmp(cglobs->cint.CompilerBotch,OUT_OF_TRAIL_BOTCH); + _longjmp(cglobs->cint.CompilerBotch,OUT_OF_TRAIL_BOTCH); case OUT_OF_HEAP_ERROR: Yap_Error_TYPE = YAP_NO_ERROR; - longjmp(cglobs->cint.CompilerBotch,OUT_OF_HEAP_BOTCH); + _longjmp(cglobs->cint.CompilerBotch,OUT_OF_HEAP_BOTCH); case OUT_OF_AUXSPACE_ERROR: Yap_Error_TYPE = YAP_NO_ERROR; - longjmp(cglobs->cint.CompilerBotch,OUT_OF_AUX_BOTCH); + _longjmp(cglobs->cint.CompilerBotch,OUT_OF_AUX_BOTCH); default: - longjmp(cglobs->cint.CompilerBotch,COMPILER_ERR_BOTCH); + _longjmp(cglobs->cint.CompilerBotch,COMPILER_ERR_BOTCH); } } H = h0; @@ -1004,7 +1004,7 @@ c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler Yap_bip_name(Op, s); sprintf(Yap_ErrorMessage, "compiling %s/2 with output bound", s); save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,1); + _longjmp(cglobs->cint.CompilerBotch,1); } } } else { /* t1 is bound */ @@ -1019,7 +1019,7 @@ c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler Yap_bip_name(Op, s); sprintf(Yap_ErrorMessage, "compiling %s/3",s); save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,1); + _longjmp(cglobs->cint.CompilerBotch,1); } } else { if (Op == _functor) { @@ -1035,7 +1035,7 @@ c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler Yap_bip_name(Op, s); sprintf(Yap_ErrorMessage, "compiling functor/3"); save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,1); + _longjmp(cglobs->cint.CompilerBotch,1); } i2 = IntegerOfTerm(t2); if (i2 < 0) { @@ -1047,7 +1047,7 @@ c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler Yap_bip_name(Op, s); sprintf(Yap_ErrorMessage, "compiling functor/3"); save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,1); + _longjmp(cglobs->cint.CompilerBotch,1); } if (IsNumTerm(t1)) { /* we will always fail */ @@ -1062,7 +1062,7 @@ c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler Yap_bip_name(Op, s); sprintf(Yap_ErrorMessage, "compiling functor/3"); save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,1); + _longjmp(cglobs->cint.CompilerBotch,1); } if (i2 == 0) c_eq(t1, t3, cglobs); @@ -1074,7 +1074,7 @@ c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler if (H+2 >= (CELL *)cglobs->cint.freep0) { /* oops, too many new variables */ save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); + _longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); } RESET_VARIABLE(H); RESET_VARIABLE(H+1); @@ -1086,7 +1086,7 @@ c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler if (H >= (CELL *)cglobs->cint.freep0) { /* oops, too many new variables */ save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); + _longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); } RESET_VARIABLE(H); H++; @@ -1098,7 +1098,7 @@ c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler Prop p0 = PredPropByFunc(f, mod); if (EndOfPAEntr(p0)) { save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH); + _longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH); } c_args(Goal, 0, cglobs); Yap_emit(safe_call_op, (CELL)p0 , Zero, &cglobs->cint); @@ -1120,7 +1120,7 @@ c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler Yap_bip_name(Op, s); sprintf(Yap_ErrorMessage, "compiling %s/2", s); save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,1); + _longjmp(cglobs->cint.CompilerBotch,1); } if (IsAtomicTerm(t2) || (IsApplTerm(t2) && IsExtensionFunctor(FunctorOfTerm(t2)))) { @@ -1132,7 +1132,7 @@ c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler Yap_bip_name(Op, s); sprintf(Yap_ErrorMessage, "compiling %s/2", s); save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,1); + _longjmp(cglobs->cint.CompilerBotch,1); } else if (IsApplTerm(t2)) { Functor f = FunctorOfTerm(t2); if (i1 < 1 || i1 > ArityOfFunctor(f)) { @@ -1163,7 +1163,7 @@ c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler Yap_bip_name(Op, s); sprintf(Yap_ErrorMessage, "compiling %s/2", s); save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,1); + _longjmp(cglobs->cint.CompilerBotch,1); } } if (Op == _functor) { @@ -1176,7 +1176,7 @@ c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler Yap_bip_name(Op, s); sprintf(Yap_ErrorMessage, "compiling %s/2", s); save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,1); + _longjmp(cglobs->cint.CompilerBotch,1); } else { if (!IsVarTerm(t2)) { Int arity; @@ -1191,7 +1191,7 @@ c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler Yap_bip_name(Op, s); sprintf(Yap_ErrorMessage, "compiling %s/2", s); save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,1); + _longjmp(cglobs->cint.CompilerBotch,1); } arity = IntOfTerm(t2); if (arity < 0) { @@ -1209,12 +1209,12 @@ c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler Yap_bip_name(Op, s); sprintf(Yap_ErrorMessage, "compiling %s/2", s); save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,1); + _longjmp(cglobs->cint.CompilerBotch,1); } if (H+1+arity >= (CELL *)cglobs->cint.freep0) { /* oops, too many new variables */ save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); + _longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); } tnew = AbsAppl(H); *H++ = (CELL)Yap_MkFunctor(AtomOfTerm(t1),arity); @@ -1253,7 +1253,7 @@ c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler Yap_bip_name(Op, s); sprintf(Yap_ErrorMessage, "compiling %s/2 with output bound", s); save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,1); + _longjmp(cglobs->cint.CompilerBotch,1); } } /* then we compile the opcode/result */ @@ -1263,7 +1263,7 @@ c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler if (H == (CELL *)cglobs->cint.freep0) { /* oops, too many new variables */ save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); + _longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); } c_var(tmpvar,f_flag,(unsigned int)Op, 0, cglobs); c_eq(tmpvar,t3, cglobs); @@ -1276,7 +1276,7 @@ c_bifun(basic_preds Op, Term t1, Term t2, Term t3, Term Goal, Term mod, compiler Yap_bip_name(Op, s); sprintf(Yap_ErrorMessage, "compiling %s/2 with input unbound", s); save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,1); + _longjmp(cglobs->cint.CompilerBotch,1); } } else if (IsNewVar(t3) && cglobs->curbranch == 0 && cglobs->cint.CurrentPred->PredFlags & TabledPredFlag) { Term nv = MkVarTerm(); @@ -1342,7 +1342,7 @@ c_functor(Term Goal, Term mod, compiler_struct *cglobs) if (EndOfPAEntr(p0)) { save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH); + _longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH); } if (profiling) Yap_emit(enter_profiling_op, (CELL)RepPredProp(p0), Zero, &cglobs->cint); @@ -1443,7 +1443,7 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs) Yap_Error_Term = M; Yap_ErrorMessage = "in module name"; save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH); + _longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH); } Goal = ArgOfTerm(2, Goal); mod = M; @@ -1561,7 +1561,7 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs) p = RepPredProp(p0 = Yap_PredPropByAtomNonThreadLocal(atom, mod)); if (EndOfPAEntr(p0)) { save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH); + _longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH); } /* if we are profiling, make sure we register we entered this predicate */ if (profiling) @@ -1574,7 +1574,7 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs) p = RepPredProp(p0 = Yap_PredPropByFunctorNonThreadLocal(f, mod)); if (EndOfPAEntr(p0)) { save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH); + _longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH); } if (f == FunctorOr || f == FunctorVBar) { Term arg; @@ -1649,7 +1649,7 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs) if (H == (CELL *)cglobs->cint.freep0) { /* oops, too many new variables */ save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); + _longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); } savecpc = cglobs->cint.cpc; savencpc = FirstP->nextInst; @@ -1732,7 +1732,7 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs) if (H == (CELL *)cglobs->cint.freep0) { /* oops, too many new variables */ save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); + _longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); } push_branch(cglobs->onbranch, commitvar, cglobs); ++cglobs->curbranch; @@ -1767,7 +1767,7 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs) if (H == (CELL *)cglobs->cint.freep0) { /* oops, too many new variables */ save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); + _longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); } cglobs->onlast = FALSE; c_var(commitvar, save_b_flag, 1, 0, cglobs); @@ -1882,7 +1882,7 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs) Yap_ErrorMessage = Yap_ErrorSay; sprintf(Yap_ErrorMessage, "compiling %s/2 with second arg unbound", RepAtom(NameOfFunctor(p->FunctorOfPred))->StrOfAE); save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,1); + _longjmp(cglobs->cint.CompilerBotch,1); } c_var(a1, bt1_flag, 2, 0, cglobs); cglobs->current_p0 = p0; @@ -1893,7 +1893,7 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs) if (H == (CELL *)cglobs->cint.freep0) { /* oops, too many new variables */ save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); + _longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); } c_eq(t2, a2, cglobs); c_var(a1, bt1_flag, 2, 0, cglobs); @@ -1906,7 +1906,7 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs) if (H == (CELL *)cglobs->cint.freep0) { /* oops, too many new variables */ save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); + _longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); } c_eq(t1, a1, cglobs); @@ -1920,7 +1920,7 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs) if (H == (CELL *)cglobs->cint.freep0) { /* oops, too many new variables */ save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); + _longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH); } c_eq(t2, a2, cglobs); c_var(t1, bt1_flag, 2, 0, cglobs); @@ -2287,7 +2287,7 @@ clear_bvarray(int var, CELL *bvarray Yap_ErrorMessage = "compiler internal error: variable initialised twice"; fprintf(stderr," vsc: compiling7\n"); save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH); + _longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH); } cglobs->pbvars++; #endif @@ -2328,7 +2328,7 @@ push_bvmap(int label, PInstr *pcpc, compiler_struct *cglobs) Yap_Error_Term = TermNil; Yap_ErrorMessage = "Too many embedded disjunctions"; save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH); + _longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH); } /* the label instruction */ bvstack[bvindex].lab = label; @@ -2351,7 +2351,7 @@ reset_bvmap(CELL *bvarray, int nperm, compiler_struct *cglobs) Yap_Error_Term = TermNil; Yap_ErrorMessage = "No embedding in disjunctions"; save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH); + _longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH); } env_size = (bvstack[bvindex-1].pc)->rnd1; size = env_size/(8*sizeof(CELL)); @@ -2371,7 +2371,7 @@ pop_bvmap(CELL *bvarray, int nperm, compiler_struct *cglobs) Yap_Error_Term = TermNil; Yap_ErrorMessage = "Too few embedded disjunctions"; /* save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH); */ + _longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH); */ } reset_bvmap(bvarray, nperm, cglobs); bvindex--; @@ -2641,7 +2641,7 @@ checktemp(Int arg, Int rn, compiler_vm_op ic, compiler_struct *cglobs) Yap_Error_Term = TermNil; Yap_ErrorMessage = "too many temporaries"; save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH); + _longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH); } v->NoOfVE = cglobs->vadr = vadr = TempVar | target1; v->KindOfVE = TempVar; @@ -2774,7 +2774,7 @@ c_layout(compiler_struct *cglobs) Yap_Error_Term = TermNil; Yap_ErrorMessage = "wrong number of variables found in bitmap"; save_machine_regs(); - longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH); + _longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH); } #endif } @@ -3319,7 +3319,7 @@ Yap_cclause(volatile Term inp_clause, Int NOfArgs, Term mod, volatile Term src) /* make sure we know there was no error yet */ Yap_ErrorMessage = NULL; - if ((botch_why = setjmp(cglobs.cint.CompilerBotch))) { + if ((botch_why = _setjmp(cglobs.cint.CompilerBotch))) { restore_machine_regs(); reset_vars(cglobs.vtable); Yap_ReleaseCMem(&cglobs.cint); @@ -3420,7 +3420,7 @@ Yap_cclause(volatile Term inp_clause, Int NOfArgs, Term mod, volatile Term src) cglobs.vtable = NULL; Yap_Error_Size = (256+maxvnum)*sizeof(CELL); save_machine_regs(); - longjmp(cglobs.cint.CompilerBotch,3); + _longjmp(cglobs.cint.CompilerBotch,3); } cglobs.Uses = (Int *)(H+maxvnum); cglobs.Contents = (Term *)(H+maxvnum+(sizeof(Int)/sizeof(CELL))*MaxTemps); diff --git a/C/computils.c b/C/computils.c index b9f2738e9..2011bfe8c 100755 --- a/C/computils.c +++ b/C/computils.c @@ -122,7 +122,7 @@ AllocCMem (UInt size, struct intermediates *cip) if (!p) { Yap_Error_Size = size; save_machine_regs(); - longjmp(cip->CompilerBotch, OUT_OF_HEAP_BOTCH); + _longjmp(cip->CompilerBotch, OUT_OF_HEAP_BOTCH); } Yap_CMemFirstBlock = p; Yap_CMemFirstBlockSz = blksz; @@ -132,7 +132,7 @@ AllocCMem (UInt size, struct intermediates *cip) if (!p) { Yap_Error_Size = size; save_machine_regs(); - longjmp(cip->CompilerBotch, OUT_OF_HEAP_BOTCH); + _longjmp(cip->CompilerBotch, OUT_OF_HEAP_BOTCH); } } p->u.next = cip->blks; @@ -152,7 +152,7 @@ AllocCMem (UInt size, struct intermediates *cip) if (ASP <= CellPtr (cip->freep) + 256) { Yap_Error_Size = 256+((char *)cip->freep - (char *)H); save_machine_regs(); - longjmp(cip->CompilerBotch, OUT_OF_STACK_BOTCH); + _longjmp(cip->CompilerBotch, OUT_OF_STACK_BOTCH); } return (p); #endif diff --git a/C/heapgc.c b/C/heapgc.c index 243709de1..53b51e8c1 100755 --- a/C/heapgc.c +++ b/C/heapgc.c @@ -165,7 +165,7 @@ gc_growtrail(int committed, tr_fr_ptr begsTR, cont *old_cont_top0) #endif /* could not find more trail */ save_machine_regs(); - longjmp(Yap_gc_restore, 2); + _longjmp(Yap_gc_restore, 2); } } @@ -425,7 +425,7 @@ check_pr_trail(tr_fr_ptr trp) if (!Yap_growtrail(0, TRUE) || TRUE) { /* could not find more trail */ save_machine_regs(); - longjmp(Yap_gc_restore, 2); + _longjmp(Yap_gc_restore, 2); } } } @@ -3782,7 +3782,7 @@ do_gc(Int predarity, CELL *current_env, yamop *nextop) } #endif time_start = Yap_cputime(); - if (setjmp(Yap_gc_restore) == 2) { + if (_setjmp(Yap_gc_restore) == 2) { UInt sz; /* we cannot recover, fail system */ diff --git a/C/index.c b/C/index.c index db02e1eff..cbf541a6b 100644 --- a/C/index.c +++ b/C/index.c @@ -188,7 +188,7 @@ * Revision 1.150 2005/12/23 00:20:13 vsc * updates to gprof * support for __POWER__ -* Try to saveregs before longjmp. +* Try to saveregs before _longjmp. * * Revision 1.149 2005/12/17 03:25:39 vsc * major changes to support online event-based profiling @@ -832,14 +832,14 @@ sort_group(GroupDef *grp, CELL *top, struct intermediates *cint) if (!(base = (CELL *)Yap_AllocCodeSpace(2*max*sizeof(CELL)))) { save_machine_regs(); Yap_Error_Size = 2*max*sizeof(CELL); - longjmp(cint->CompilerBotch,2); + _longjmp(cint->CompilerBotch,2); } #else base = top; while (top+2*max > (CELL *)Yap_TrailTop) { if (!Yap_growtrail(2*max*CellSize, TRUE)) { save_machine_regs(); - longjmp(cint->CompilerBotch,4); + _longjmp(cint->CompilerBotch,4); return; } } @@ -2046,11 +2046,11 @@ groups_in(ClauseDef *min, ClauseDef *max, GroupDef *grp, struct intermediates *c Yap_Error_Size = sz; /* grow stack */ save_machine_regs(); - longjmp(cint->CompilerBotch,4); + _longjmp(cint->CompilerBotch,4); #else if (!Yap_growtrail(sz, TRUE)) { save_machine_regs(); - longjmp(cint->CompilerBotch,4); + _longjmp(cint->CompilerBotch,4); return 0; } #endif @@ -2179,7 +2179,7 @@ emit_switch_space(UInt n, UInt item_size, struct intermediates *cint, CELL func_ if (cl == NULL) { /* grow stack */ save_machine_regs(); - longjmp(cint->CompilerBotch,2); + _longjmp(cint->CompilerBotch,2); } Yap_LUIndexSpace_SW += sz; cl->ClFlags = SwitchTableMask|LogUpdMask|func_mask; @@ -2199,7 +2199,7 @@ emit_switch_space(UInt n, UInt item_size, struct intermediates *cint, CELL func_ if (cl == NULL) { /* grow stack */ save_machine_regs(); - longjmp(cint->CompilerBotch,2); + _longjmp(cint->CompilerBotch,2); } Yap_IndexSpace_SW += sz; cl->ClFlags = SwitchTableMask; @@ -2518,7 +2518,7 @@ suspend_indexing(ClauseDef *min, ClauseDef *max, PredEntry *ap, struct intermedi sz = (UInt)NEXTOP((yamop *)NULL,sssllp)+tels*sizeof(yamop *); if ((ncode = (yamop *)Yap_AllocCodeSpace(sz)) == NULL) { save_machine_regs(); - longjmp(cint->CompilerBotch, 2); + _longjmp(cint->CompilerBotch, 2); } #if DEBUG Yap_ExpandClauses++; @@ -3130,7 +3130,7 @@ copy_clauses(ClauseDef *max0, ClauseDef *min0, CELL *top, struct intermediates * Yap_Error_Size = sz; /* grow stack */ save_machine_regs(); - longjmp(cint->CompilerBotch,4); + _longjmp(cint->CompilerBotch,4); } memcpy((void *)top, (void *)min0, sz); return (ClauseDef *)top; @@ -3324,7 +3324,7 @@ compile_index(struct intermediates *cint) Yap_Error_Size += NClauses*sizeof(ClauseDef); /* grow stack */ save_machine_regs(); - longjmp(cint->CompilerBotch,2); + _longjmp(cint->CompilerBotch,2); } } cint->freep = (char *)H; @@ -3336,7 +3336,7 @@ compile_index(struct intermediates *cint) Yap_Error_Size += NClauses*sizeof(ClauseDef); /* grow stack */ save_machine_regs(); - longjmp(cint->CompilerBotch,3); + _longjmp(cint->CompilerBotch,3); } cint->freep = (char *)(cint->cls+NClauses); #endif @@ -3381,7 +3381,7 @@ Yap_PredIsIndexable(PredEntry *ap, UInt NSlots, yamop *next_pc) cint.cls = NULL; Yap_Error_Size = 0; - if ((setjres = setjmp(cint.CompilerBotch)) == 3) { + if ((setjres = _setjmp(cint.CompilerBotch)) == 3) { restore_machine_regs(); recover_from_failed_susp_on_cls(&cint, 0); if (!Yap_gcl(Yap_Error_Size, ap->ArityOfPE+NSlots, ENV, next_pc)) { @@ -3463,7 +3463,7 @@ push_stack(istack_entry *sp, Int arg, Term Tag, Term extra, struct intermediates { if (sp+1 > (istack_entry *)Yap_TrailTop) { save_machine_regs(); - longjmp(cint->CompilerBotch,4); + _longjmp(cint->CompilerBotch,4); } sp->pos = arg; sp->val = Tag; @@ -4349,7 +4349,7 @@ expand_index(struct intermediates *cint) { Yap_Error_Size += NClauses*sizeof(ClauseDef); /* grow stack */ save_machine_regs(); - longjmp(cint->CompilerBotch,2); + _longjmp(cint->CompilerBotch,2); } } #else @@ -4359,7 +4359,7 @@ expand_index(struct intermediates *cint) { Yap_Error_Size += 2*NClauses*sizeof(ClauseDef); /* grow stack */ save_machine_regs(); - longjmp(cint->CompilerBotch,3); + _longjmp(cint->CompilerBotch,3); } #endif if (ap->PredFlags & LogUpdatePredFlag) { @@ -4377,7 +4377,7 @@ expand_index(struct intermediates *cint) { Yap_Error_Size += NClauses*sizeof(ClauseDef); /* grow stack */ save_machine_regs(); - longjmp(cint->CompilerBotch,2); + _longjmp(cint->CompilerBotch,2); } } #else @@ -4386,7 +4386,7 @@ expand_index(struct intermediates *cint) { /* tell how much space we need (worst case) */ Yap_Error_Size += 2*NClauses*sizeof(ClauseDef); save_machine_regs(); - longjmp(cint->CompilerBotch,3); + _longjmp(cint->CompilerBotch,3); } #endif if (ap->PredFlags & LogUpdatePredFlag) { @@ -4485,7 +4485,7 @@ ExpandIndex(PredEntry *ap, int ExtraArgs, yamop *nextop) { cint.cls = NULL; cint.code_addr = NULL; cint.label_offset = NULL; - if ((cb = setjmp(cint.CompilerBotch)) == 3) { + if ((cb = _setjmp(cint.CompilerBotch)) == 3) { restore_machine_regs(); /* grow stack */ recover_from_failed_susp_on_cls(&cint, 0); @@ -4695,7 +4695,7 @@ push_path(path_stack_entry *sp, yamop **pipc, ClauseDef *clp, struct intermediat { if (sp+1 > (path_stack_entry *)Yap_TrailTop) { save_machine_regs(); - longjmp(cint->CompilerBotch,4); + _longjmp(cint->CompilerBotch,4); } sp->flag = pc_entry; sp->u.pce.pi_pc = pipc; @@ -4711,7 +4711,7 @@ fetch_new_block(path_stack_entry *sp, yamop **pipc, PredEntry *ap, struct interm { if (sp+1 > (path_stack_entry *)Yap_TrailTop) { save_machine_regs(); - longjmp(cint->CompilerBotch,4); + _longjmp(cint->CompilerBotch,4); } /* add current position */ sp->flag = block_entry; @@ -5484,9 +5484,9 @@ add_try(PredEntry *ap, ClauseDef *cls, yamop *next, struct intermediates *cint) LogUpdClause *lcl = ClauseCodeToLogUpdClause(cls->Code); if ((newcp = (yamop *)Yap_AllocCodeSpace(size)) == NULL) { - /* OOOPS, got in trouble, must do a longjmp and recover space */ + /* OOOPS, got in trouble, must do a _longjmp and recover space */ save_machine_regs(); - longjmp(cint->CompilerBotch,2); + _longjmp(cint->CompilerBotch,2); } Yap_LUIndexSpace_CP += size; #ifdef DEBUG @@ -5510,9 +5510,9 @@ add_trust(LogUpdIndex *icl, ClauseDef *cls, struct intermediates *cint) PredEntry *ap = lcl->ClPred; if ((newcp = (yamop *)Yap_AllocCodeSpace(size)) == NULL) { - /* OOOPS, got in trouble, must do a longjmp and recover space */ + /* OOOPS, got in trouble, must do a _longjmp and recover space */ save_machine_regs(); - longjmp(cint->CompilerBotch,2); + _longjmp(cint->CompilerBotch,2); } Yap_LUIndexSpace_CP += size; #ifdef DEBUG @@ -6000,7 +6000,7 @@ Yap_AddClauseToIndex(PredEntry *ap, yamop *beg, int first) { cint.CurrentPred = ap; cint.expand_block = NULL; cint.CodeStart = cint.BlobsStart = cint.cpc = cint.icpc = NIL; - if ((cb = setjmp(cint.CompilerBotch)) == 3) { + if ((cb = _setjmp(cint.CompilerBotch)) == 3) { restore_machine_regs(); Yap_gcl(Yap_Error_Size, ap->ArityOfPE, ENV, CP); save_machine_regs(); @@ -6476,7 +6476,7 @@ Yap_RemoveClauseFromIndex(PredEntry *ap, yamop *beg) { } cint.expand_block = NULL; cint.CodeStart = cint.BlobsStart = cint.cpc = cint.icpc = NULL; - if ((cb = setjmp(cint.CompilerBotch)) == 3) { + if ((cb = _setjmp(cint.CompilerBotch)) == 3) { restore_machine_regs(); Yap_gcl(Yap_Error_Size, ap->ArityOfPE, ENV, CP); save_machine_regs(); diff --git a/C/iopreds.c b/C/iopreds.c index 6f9510bd7..b0951497d 100755 --- a/C/iopreds.c +++ b/C/iopreds.c @@ -780,7 +780,7 @@ MemPutc(int sno, int ch) if (Stream[sno].u.mem_string.error_handler) { Yap_Error_Size = new_max_size*sizeof(char); save_machine_regs(); - longjmp(*(jmp_buf *)Stream[sno].u.mem_string.error_handler,1); + _longjmp(*(jmp_buf *)Stream[sno].u.mem_string.error_handler,1); } else { Yap_Error(OUT_OF_HEAP_ERROR, TermNil, "YAP could not grow heap for writing to string"); } @@ -4354,7 +4354,7 @@ static Int while (TRUE) { CELL *old_H = H; - if (setjmp(Yap_IOBotch) == 0) { + if (_setjmp(Yap_IOBotch) == 0) { v = Yap_VarNames(Yap_VarTable, TermNil); break; } else { @@ -5145,7 +5145,7 @@ format(volatile Term otail, volatile Term oargs, int sno) Stream[sno].u.mem_string.error_handler = (void *)&format_botch; old_pos = Stream[sno].u.mem_string.pos; /* set up an error handler */ - if (setjmp(format_botch)) { + if (_setjmp(format_botch)) { restore_machine_regs(); *H++ = oargs; *H++ = otail; diff --git a/C/parser.c b/C/parser.c index b499296b8..d10863f03 100644 --- a/C/parser.c +++ b/C/parser.c @@ -81,7 +81,7 @@ STATIC_PROTO(Term ParseTerm, (int, JMPBUFF *)); Volatile CELL *saveH=H; \ Volatile int savecurprio=curprio; \ saveenv=FailBuff; \ - if(!setjmp(newenv.JmpBuff)) { \ + if(!_setjmp(newenv.JmpBuff)) { \ FailBuff = &newenv; \ S; \ FailBuff=saveenv; \ @@ -99,7 +99,7 @@ STATIC_PROTO(Term ParseTerm, (int, JMPBUFF *)); Volatile TokEntry *saveT=Yap_tokptr; \ Volatile CELL *saveH=H; \ saveenv=FailBuff; \ - if(!setjmp(newenv.JmpBuff)) { \ + if(!_setjmp(newenv.JmpBuff)) { \ FailBuff = &newenv; \ S; \ FailBuff=saveenv; \ @@ -113,7 +113,7 @@ STATIC_PROTO(Term ParseTerm, (int, JMPBUFF *)); } -#define FAIL longjmp(FailBuff->JmpBuff,1) +#define FAIL _longjmp(FailBuff->JmpBuff,1) VarEntry * Yap_LookupVar(char *var) /* lookup variable in variables table */ @@ -181,7 +181,7 @@ VarNames(VarEntry *p,Term l) VarNames(p->VarLeft,l))); if (H > ASP-4096) { save_machine_regs(); - longjmp(Yap_IOBotch,1); + _longjmp(Yap_IOBotch,1); } return(o); } else { @@ -710,7 +710,7 @@ Yap_Parse(void) Volatile Term t; JMPBUFF FailBuff; - if (!setjmp(FailBuff.JmpBuff)) { + if (!_setjmp(FailBuff.JmpBuff)) { t = ParseTerm(1200, &FailBuff); if (Yap_tokptr->Tok != Ord(eot_tok)) return (0L); diff --git a/H/Yap.h b/H/Yap.h index 458c5295d..3cfe37d0e 100755 --- a/H/Yap.h +++ b/H/Yap.h @@ -245,6 +245,11 @@ typedef unsigned long int YAP_ULONG_LONG; #define LOW_PROF 1 #endif +#if !HAVE__SETJMP +#define _longjmp(A,B) longjmp(A,B) +#define _setjmp(A) setjmp(A) +#endif + #ifdef DEBUG extern char Yap_Option[20]; #endif diff --git a/config.h.in b/config.h.in index f741308a0..26d28cac7 100755 --- a/config.h.in +++ b/config.h.in @@ -167,6 +167,7 @@ #undef RETSIGTYPE #undef HAVE__NSGETENVIRON +#undef HAVE__SETJMP #undef HAVE_ACCESS #undef HAVE_ACOSH #undef HAVE_ALARM diff --git a/configure b/configure index 9ae12012a..5cbd4d0a6 100755 --- a/configure +++ b/configure @@ -8569,6 +8569,46 @@ $as_echo "#define HAVE_SIGSETJMP 0" >>confdefs.h fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for _setjmp" >&5 +$as_echo_n "checking for _setjmp... " >&6; } +if ${yap_cv__setjmp+:} false; then : + $as_echo_n "(cached) " >&6 +else + +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + +int +main () +{ +jmp_buf RestartEnv; + + _longjmp (RestartEnv, 1); + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + yap_cv__setjmp=yes +else + yap_cv__setjmp=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $yap_cv__setjmp" >&5 +$as_echo "$yap_cv__setjmp" >&6; } +if test "$yap_cv__setjmp" = yes +then +$as_echo "#define HAVE__SETJMP 1" >>confdefs.h + +else +$as_echo "#define HAVE__SETJMP 0" >>confdefs.h + +fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sigsegv" >&5 $as_echo_n "checking for sigsegv... " >&6; } if ${yap_cv_sigsegv+:} false; then : diff --git a/configure.in b/configure.in index 93a53a0f9..3f131d636 100755 --- a/configure.in +++ b/configure.in @@ -1567,6 +1567,25 @@ else AC_DEFINE(HAVE_SIGSETJMP,0) fi +dnl check for _setjmp +AC_MSG_CHECKING(for _setjmp) +AC_CACHE_VAL(yap_cv__setjmp,[ +AC_TRY_COMPILE( + #include + , + jmp_buf RestartEnv; + + _longjmp (RestartEnv, 1); + , + yap_cv__setjmp=yes,yap_cv__setjmp=no)]) +AC_MSG_RESULT($yap_cv__setjmp) +if test "$yap_cv__setjmp" = yes +then +AC_DEFINE(HAVE__SETJMP,1) +else +AC_DEFINE(HAVE__SETJMP,0) +fi + dnl check for sigsegv AC_MSG_CHECKING(for sigsegv) AC_CACHE_VAL(yap_cv_sigsegv,[ From 95acd408e72f0b36041823866c56ce0dd2d94319 Mon Sep 17 00:00:00 2001 From: Vitor Santos Costa Date: Wed, 27 Oct 2010 10:11:19 +0100 Subject: [PATCH 09/10] support DragonFly BSD (patch from Aleksej Saushev) --- C/sysbits.c | 4 ++-- H/Yap.h | 4 ++-- configure | 2 +- configure.in | 2 +- packages/clib/sha1/brg_endian.h | 2 +- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/C/sysbits.c b/C/sysbits.c index e5336667b..30491f445 100755 --- a/C/sysbits.c +++ b/C/sysbits.c @@ -293,7 +293,7 @@ InitPageSize(void) GetSystemInfo(&si); Yap_page_size = si.dwPageSize; #elif HAVE_UNISTD_H -#ifdef __FreeBSD__ +#if defined(__FreeBSD__) || defined(__DragonFly__) Yap_page_size = getpagesize(); #elif defined(_AIX) Yap_page_size = sysconf(_SC_PAGE_SIZE); @@ -575,7 +575,7 @@ void Yap_systime_interval(Int *now,Int *interval) #define TicksPerSec CLK_TCK #endif -#if defined(__alpha) || defined(__FreeBSD__) || defined(__linux__) +#if defined(__alpha) || defined(__FreeBSD__) || defined(__linux__) || defined(__DragonFly__) #if HAVE_TIME_H #include diff --git a/H/Yap.h b/H/Yap.h index 3cfe37d0e..44ec886fa 100755 --- a/H/Yap.h +++ b/H/Yap.h @@ -262,7 +262,7 @@ extern char Yap_Option[20]; #endif #if !defined(IN_SECOND_QUADRANT) -#if __linux__ || __FreeBSD__ || __NetBSD__ || mips || __APPLE__ +#if defined(__linux__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(mips) || defined(__APPLE__) || defined(__DragonFly__) #if defined(YAPOR) && defined(__alpha) #define MMAP_ADDR 0x40000000 @@ -688,7 +688,7 @@ typedef enum if you place things in the lower addresses (power to the libc people). */ -#if (defined(_AIX) || (defined(__APPLE__) && !defined(__LP64__)) || defined(_WIN32) || defined(sparc) || defined(__sparc) || defined(mips) || defined(__FreeBSD__) || defined(_POWER) || defined(__POWERPC__) || defined(__linux__) || defined(IN_SECOND_QUADRANT) || defined(__CYGWIN__)) || defined(__NetBSD__) +#if (defined(_AIX) || (defined(__APPLE__) && !defined(__LP64__)) || defined(_WIN32) || defined(sparc) || defined(__sparc) || defined(mips) || defined(__FreeBSD__) || defined(_POWER) || defined(__POWERPC__) || defined(__linux__) || defined(IN_SECOND_QUADRANT) || defined(__CYGWIN__)) || defined(__NetBSD__) || defined(__DragonFly__) #define USE_LOW32_TAGS 1 #endif diff --git a/configure b/configure index 5cbd4d0a6..0aea35d4b 100755 --- a/configure +++ b/configure @@ -7166,7 +7166,7 @@ fi YAPLIB_LD="$CC -dynamiclib -Wl,-install_name,$prefix/lib/libYap.dylib" PRE_INSTALL_ENV="DYLD_LIBRARY_PATH=\$(abs_top_builddir)" ;; - *netbsd*|*freebsd*) + *netbsd*|*openbsd*|*freebsd*|*dragonfly*) if echo __ELF__ | ${CC:-cc} -E - | grep -q __ELF__ then #an a.out system diff --git a/configure.in b/configure.in index 3f131d636..920d01acd 100755 --- a/configure.in +++ b/configure.in @@ -1069,7 +1069,7 @@ dnl Linux has both elf and a.out, in this case we found elf YAPLIB_LD="$CC -dynamiclib -Wl,-install_name,$prefix/lib/libYap.dylib" PRE_INSTALL_ENV="DYLD_LIBRARY_PATH=\$(abs_top_builddir)" ;; - *netbsd*|*freebsd*) + *netbsd*|*openbsd*|*freebsd*|*dragonfly*) if echo __ELF__ | ${CC:-cc} -E - | grep -q __ELF__ then #an a.out system diff --git a/packages/clib/sha1/brg_endian.h b/packages/clib/sha1/brg_endian.h index 4f7eee0ed..7609e4b0c 100644 --- a/packages/clib/sha1/brg_endian.h +++ b/packages/clib/sha1/brg_endian.h @@ -39,7 +39,7 @@ /* Include files where endian defines and byteswap functions may reside */ #if defined(__sun__) # include -#elif defined( __FreeBSD__ ) || defined( __OpenBSD__ ) || defined( __NetBSD__ ) +#elif defined( __FreeBSD__ ) || defined( __OpenBSD__ ) || defined( __NetBSD__ ) || defined( __DragonFly__ ) # include #elif defined( BSD ) && ( BSD >= 199103 ) || defined( __APPLE__ ) || \ defined( __CYGWIN32__ ) || defined( __DJGPP__ ) || defined( __osf__ ) From 9396252588e897413f2692edbd287b32366f1346 Mon Sep 17 00:00:00 2001 From: Vitor Santos Costa Date: Wed, 27 Oct 2010 14:49:27 +0100 Subject: [PATCH 10/10] patches to provide initial support UTF32 encodings(from Paulo Moura) --- C/errors.c | 15 +++ C/iopreds.c | 236 ++++++++++++++++++++++++++++++++++++++++++------ H/Yap.h | 1 + H/iatoms.h | 1 + H/ratoms.h | 1 + H/tatoms.h | 2 + H/yapio.h | 4 +- misc/ATOMS | 1 + pl/messages.yap | 2 + 9 files changed, 235 insertions(+), 28 deletions(-) mode change 100755 => 100644 C/iopreds.c diff --git a/C/errors.c b/C/errors.c index 97a1ceab6..f372b9828 100644 --- a/C/errors.c +++ b/C/errors.c @@ -798,6 +798,21 @@ Yap_Error(yap_error_number type, Term where, char *format,...) serious = TRUE; } break; + case DOMAIN_ERROR_STREAM_ENCODING: + { + int i; + Term ti[2]; + + i = strlen(tmpbuf); + ti[0] = MkAtomTerm(AtomEncoding); + ti[1] = where; + nt[0] = Yap_MkApplTerm(FunctorDomainError, 2, ti); + tp = tmpbuf+i; + psize -= i; + fun = FunctorError; + serious = TRUE; + } + break; case DOMAIN_ERROR_STREAM_POSITION: { int i; diff --git a/C/iopreds.c b/C/iopreds.c old mode 100755 new mode 100644 index b0951497d..e31e0f78a --- a/C/iopreds.c +++ b/C/iopreds.c @@ -780,7 +780,7 @@ MemPutc(int sno, int ch) if (Stream[sno].u.mem_string.error_handler) { Yap_Error_Size = new_max_size*sizeof(char); save_machine_regs(); - _longjmp(*(jmp_buf *)Stream[sno].u.mem_string.error_handler,1); + longjmp(*(jmp_buf *)Stream[sno].u.mem_string.error_handler,1); } else { Yap_Error(OUT_OF_HEAP_ERROR, TermNil, "YAP could not grow heap for writing to string"); } @@ -1736,6 +1736,21 @@ PlUnGetc376 (int sno) return ch; } +/* give back 0376+ch */ +static int +PlUnGetc00 (int sno) +{ + register StreamDesc *s = &Stream[sno]; + Int ch; + + if (s->stream_getc != PlUnGetc00) + return(s->stream_getc(sno)); + s->stream_getc = PlUnGetc; + ch = s->och; + s->och = 0x00; + return ch; +} + /* give back 0377+ch */ static int PlUnGetc377 (int sno) @@ -1781,6 +1796,66 @@ PlUnGetc357273 (int sno) return ch; } +/* give back 000+000+ch */ +static int +PlUnGetc0000 (int sno) +{ + register StreamDesc *s = &Stream[sno]; + Int ch; + + if (s->stream_getc != PlUnGetc0000) + return(s->stream_getc(sno)); + s->stream_getc = PlUnGetc00; + ch = s->och; + s->och = 0x00; + return ch; +} + +/* give back 000+000+ch */ +static int +PlUnGetc0000fe (int sno) +{ + register StreamDesc *s = &Stream[sno]; + Int ch; + + if (s->stream_getc != PlUnGetc0000fe) + return(s->stream_getc(sno)); + s->stream_getc = PlUnGetc0000; + ch = s->och; + s->och = 0xfe; + return ch; +} + +/* give back 0377+0376+ch */ +static int +PlUnGetc377376 (int sno) +{ + register StreamDesc *s = &Stream[sno]; + Int ch; + + if (s->stream_getc != PlUnGetc377376) + return(s->stream_getc(sno)); + s->stream_getc = PlUnGetc377; + ch = s->och; + s->och = 0xFE; + return ch; +} + +/* give back 0377+0376+000+ch */ +static int +PlUnGetc37737600 (int sno) +{ + register StreamDesc *s = &Stream[sno]; + Int ch; + + if (s->stream_getc != PlUnGetc37737600) + return(s->stream_getc(sno)); + s->stream_getc = PlUnGetc377376; + ch = s->och; + s->och = 0x00; + return ch; +} + static int utf8_nof(char ch) { @@ -1886,6 +1961,26 @@ get_wchar(int sno) how_many=1; wch = ch; break; + case ENC_ISO_UTF32_LE: + if (!how_many) { + how_many = 4; + wch = 0; + } + how_many--; + wch += ((unsigned char) (ch & 0xff)) << (how_many*8); + if (how_many == 0) + return wch; + break; + case ENC_ISO_UTF32_BE: + if (!how_many) { + how_many = 4; + wch = 0; + } + how_many--; + wch += ((unsigned char) (ch & 0xff)) << ((3-how_many)*8); + if (how_many == 0) + return wch; + break; } } return EOF; @@ -1992,6 +2087,16 @@ put_wchar(int sno, wchar_t ch) case ENC_UNICODE_LE: Stream[sno].stream_putc(sno, (ch&0xff)); return Stream[sno].stream_putc(sno, (ch>>8)); + case ENC_ISO_UTF32_BE: + Stream[sno].stream_putc(sno, (ch>>24) & 0xff); + Stream[sno].stream_putc(sno, (ch>>16) &0xff); + Stream[sno].stream_putc(sno, (ch>>8) & 0xff); + return Stream[sno].stream_putc(sno, ch&0xff); + case ENC_ISO_UTF32_LE: + Stream[sno].stream_putc(sno, ch&0xff); + Stream[sno].stream_putc(sno, (ch>>8) & 0xff); + Stream[sno].stream_putc(sno, (ch>>16) &0xff); + return Stream[sno].stream_putc(sno, (ch>>24) & 0xff); } } return -1; @@ -2219,6 +2324,24 @@ write_bom(int sno, StreamDesc *st) return FALSE; if (st->stream_putc(sno,0xFE)<0) return FALSE; + case ENC_ISO_UTF32_BE: + if (st->stream_putc(sno,0x00)<0) + return FALSE; + if (st->stream_putc(sno,0x00)<0) + return FALSE; + if (st->stream_putc(sno,0xFE)<0) + return FALSE; + if (st->stream_putc(sno,0xFF)<0) + return FALSE; + case ENC_ISO_UTF32_LE: + if (st->stream_putc(sno,0xFF)<0) + return FALSE; + if (st->stream_putc(sno,0xFE)<0) + return FALSE; + if (st->stream_putc(sno,0x00)<0) + return FALSE; + if (st->stream_putc(sno,0x00)<0) + return FALSE; default: return TRUE; } @@ -2240,36 +2363,87 @@ check_bom(int sno, StreamDesc *st) return TRUE; } switch(ch) { + case 0x00: + { + ch = st->stream_getc(sno); + if (ch == EOFCHAR || ch != 0x00) { + st->och = ch; + st->stream_getc = PlUnGetc00; + st->stream_wgetc = get_wchar; + st->stream_gets = DefaultGets; + return TRUE; + } else { + ch = st->stream_getc(sno); + if (ch == EOFCHAR || ch != 0xFE) { + st->och = ch; + st->stream_getc = PlUnGetc0000; + st->stream_wgetc = get_wchar; + st->stream_gets = DefaultGets; + return TRUE; + } else { + if (ch == EOFCHAR || ch != 0xFF) { + st->och = ch; + st->stream_getc = PlUnGetc0000fe; + st->stream_wgetc = get_wchar; + st->stream_gets = DefaultGets; + return TRUE; + } else { + st->status |= HAS_BOM_f; + st->encoding = ENC_ISO_UTF32_BE; + return TRUE; + } + } + } + } case 0xFE: { ch = st->stream_getc(sno); if (ch != 0xFF) { - st->och = ch; - st->stream_getc = PlUnGetc376; - st->stream_wgetc = get_wchar; - st->stream_gets = DefaultGets; - return TRUE; + st->och = ch; + st->stream_getc = PlUnGetc376; + st->stream_wgetc = get_wchar; + st->stream_gets = DefaultGets; + return TRUE; } else { - st->status |= HAS_BOM_f; - st->encoding = ENC_UNICODE_BE; - return TRUE; + st->status |= HAS_BOM_f; + st->encoding = ENC_UNICODE_BE; + return TRUE; } } case 0xFF: { ch = st->stream_getc(sno); if (ch != 0xFE) { - st->och = ch; - st->stream_getc = PlUnGetc377; - st->stream_wgetc = get_wchar; - st->stream_gets = DefaultGets; - return TRUE; + st->och = ch; + st->stream_getc = PlUnGetc377; + st->stream_wgetc = get_wchar; + st->stream_gets = DefaultGets; + return TRUE; } else { - st->status |= HAS_BOM_f; - st->encoding = ENC_UNICODE_LE; - return TRUE; + ch = st->stream_getc(sno); + if (ch == EOFCHAR || ch != 0x00) { + st->och = ch; + st->stream_getc = PlUnGetc377376; + st->stream_wgetc = get_wchar; + st->stream_gets = DefaultGets; + } else { + ch = st->stream_getc(sno); + if (ch == EOFCHAR || ch != 0x00) { + st->och = ch; + st->stream_getc = PlUnGetc37737600; + st->stream_wgetc = get_wchar; + st->stream_gets = DefaultGets; + } else { + st->status |= HAS_BOM_f; + st->encoding = ENC_ISO_UTF32_LE; + return TRUE; + } + st->status |= HAS_BOM_f; + st->encoding = ENC_UNICODE_LE; + return TRUE; } } + } case 0xEF: ch = st->stream_getc(sno); if (ch != 0xBB) { @@ -2281,15 +2455,15 @@ check_bom(int sno, StreamDesc *st) } else { ch = st->stream_getc(sno); if (ch != 0xBF) { - st->och = ch; - st->stream_getc = PlUnGetc357273; - st->stream_wgetc = get_wchar; - st->stream_gets = DefaultGets; - return TRUE; + st->och = ch; + st->stream_getc = PlUnGetc357273; + st->stream_wgetc = get_wchar; + st->stream_gets = DefaultGets; + return TRUE; } else { - st->status |= HAS_BOM_f; - st->encoding = ENC_ISO_UTF8; - return TRUE; + st->status |= HAS_BOM_f; + st->encoding = ENC_ISO_UTF8; + return TRUE; } } default: @@ -2628,6 +2802,14 @@ p_open (void) (needs_bom || (st->status & Seekable_Stream_f))) { if (!check_bom(sno, st)) return FALSE; + /* + if (st->encoding == ENC_ISO_UTF32_BE || + st->encoding == ENC_ISO_UTF32_LE) + { + Yap_Error(DOMAIN_ERROR_STREAM_ENCODING, ARG1, "unsupported stream encoding"); + return FALSE; + } + */ } st->status &= ~(Free_Stream_f); return (Yap_unify (ARG3, t)); @@ -4354,7 +4536,7 @@ static Int while (TRUE) { CELL *old_H = H; - if (_setjmp(Yap_IOBotch) == 0) { + if (setjmp(Yap_IOBotch) == 0) { v = Yap_VarNames(Yap_VarTable, TermNil); break; } else { @@ -5145,7 +5327,7 @@ format(volatile Term otail, volatile Term oargs, int sno) Stream[sno].u.mem_string.error_handler = (void *)&format_botch; old_pos = Stream[sno].u.mem_string.pos; /* set up an error handler */ - if (_setjmp(format_botch)) { + if (setjmp(format_botch)) { restore_machine_regs(); *H++ = oargs; *H++ = otail; diff --git a/H/Yap.h b/H/Yap.h index 44ec886fa..90dfbac5c 100755 --- a/H/Yap.h +++ b/H/Yap.h @@ -476,6 +476,7 @@ typedef enum DOMAIN_ERROR_SHIFT_COUNT_OVERFLOW, DOMAIN_ERROR_SOURCE_SINK, DOMAIN_ERROR_STREAM, + DOMAIN_ERROR_STREAM_ENCODING, DOMAIN_ERROR_STREAM_OR_ALIAS, DOMAIN_ERROR_STREAM_POSITION, DOMAIN_ERROR_TIMEOUT_SPEC, diff --git a/H/iatoms.h b/H/iatoms.h index 5b4c31bcf..2e628a768 100644 --- a/H/iatoms.h +++ b/H/iatoms.h @@ -84,6 +84,7 @@ AtomEOFBeforeEOT = Yap_LookupAtom("end_of_file_found_before_end_of_term"); AtomEQ = Yap_LookupAtom("="); AtomEmptyAtom = Yap_LookupAtom(""); + AtomEncoding = Yap_LookupAtom("encoding"); AtomEndOfStream = Yap_LookupAtom("$end_of_stream"); AtomEof = Yap_LookupAtom("end_of_file"); AtomEq = Yap_LookupAtom("="); diff --git a/H/ratoms.h b/H/ratoms.h index cc12ef29d..be8c91c3b 100644 --- a/H/ratoms.h +++ b/H/ratoms.h @@ -84,6 +84,7 @@ AtomEOFBeforeEOT = AtomAdjust(AtomEOFBeforeEOT); AtomEQ = AtomAdjust(AtomEQ); AtomEmptyAtom = AtomAdjust(AtomEmptyAtom); + AtomEncoding = AtomAdjust(AtomEncoding); AtomEndOfStream = AtomAdjust(AtomEndOfStream); AtomEof = AtomAdjust(AtomEof); AtomEq = AtomAdjust(AtomEq); diff --git a/H/tatoms.h b/H/tatoms.h index 1c2e21f15..8a272004a 100644 --- a/H/tatoms.h +++ b/H/tatoms.h @@ -166,6 +166,8 @@ #define AtomEQ Yap_heap_regs->AtomEQ_ Atom AtomEmptyAtom_; #define AtomEmptyAtom Yap_heap_regs->AtomEmptyAtom_ + Atom AtomEncoding_; +#define AtomEncoding Yap_heap_regs->AtomEncoding_ Atom AtomEndOfStream_; #define AtomEndOfStream Yap_heap_regs->AtomEndOfStream_ Atom AtomEof_; diff --git a/H/yapio.h b/H/yapio.h index 61dac11f4..6cb463f09 100644 --- a/H/yapio.h +++ b/H/yapio.h @@ -256,7 +256,9 @@ typedef enum { ENC_ISO_ANSI = 4, ENC_ISO_UTF8 = 8, ENC_UNICODE_BE = 16, - ENC_UNICODE_LE = 32 + ENC_UNICODE_LE = 32, + ENC_ISO_UTF32_BE = 64, + ENC_ISO_UTF32_LE = 128 } encoding_t; #endif diff --git a/misc/ATOMS b/misc/ATOMS index 081d712ae..d3c3676e7 100644 --- a/misc/ATOMS +++ b/misc/ATOMS @@ -89,6 +89,7 @@ A E N "e" A EOFBeforeEOT N "end_of_file_found_before_end_of_term" A EQ N "=" A EmptyAtom N "" +A Encoding N "encoding" A EndOfStream N "$end_of_stream" A Eof N "end_of_file" A Eq N "=" diff --git a/pl/messages.yap b/pl/messages.yap index 1cc62351d..a3f7dbbec 100644 --- a/pl/messages.yap +++ b/pl/messages.yap @@ -354,6 +354,8 @@ domain_error(stream, Opt) --> !, [ '~w is not a stream' - [Opt] ]. domain_error(stream_or_alias, Opt) --> !, [ '~w is not a stream (or alias)' - [Opt] ]. +domain_error(stream_encoding, Opt) --> !, + [ '~w is not a supported stream encoding' - [Opt] ]. domain_error(stream_position, Opt) --> !, [ '~w is not a stream position' - [Opt] ]. domain_error(stream_property, Opt) --> !,