diogo
/
yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

library(system) plus several new support builtins 

much improved garbage collector
improvements to compiler
yaptab compiles again


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@34 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
threads
vsc 2001-05-21 20:00:05 +00:00
parent e5498326b2
commit 8dcee4415b
38 changed files with 2211 additions and 1920 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
C/absmi.c
View File

@ -292,7 +292,7 @@ absmi(int inp)
#endif /* USE_THREADED_CODE */
noheapleft:
CFREG = MinStackGap*(stack_overflows+1);
CFREG = CalculateStackGap();
saveregs();
#if PUSH_REGS
restore_absmi_regs(old_regs);
@ -1604,7 +1604,7 @@ absmi(int inp)
ASP = (CELL *)B;
goto noheapleft;
}
if (CFREG != MinStackGap*(stack_overflows+1))
if (CFREG != CalculateStackGap())
goto creep;
else
goto NoStackExec;
@ -1752,12 +1752,12 @@ absmi(int inp)
if (ReadTimedVar(WokenGoals) != TermNil)
goto creepc;
else {
CFREG = MinStackGap*(stack_overflows+1);
CFREG = CalculateStackGap();
JMPNext();
}
}
#endif
if (CFREG != MinStackGap*(stack_overflows+1))
if (CFREG != CalculateStackGap())
goto creepc;
ASP = (CELL *) (((char *) Y) + PREG->u.sla.s);
if (ASP > (CELL *)B)
@ -1830,11 +1830,11 @@ absmi(int inp)
if (ReadTimedVar(WokenGoals) != TermNil)
goto creep_either;
else {
CFREG = MinStackGap*(stack_overflows+1);
CFREG = CalculateStackGap();
JMPNext();
}
}
if (CFREG != MinStackGap*(stack_overflows+1)) {
if (CFREG != CalculateStackGap()) {
goto either_notest;
}
ASP = (CELL *) (((char *) Y) + PREG->u.sla.s);
@ -1916,12 +1916,12 @@ absmi(int inp)
if (ReadTimedVar(WokenGoals) != TermNil)
goto creepde;
else {
CFREG = MinStackGap*(stack_overflows+1);
CFREG = CalculateStackGap();
JMPNext();
}
}
#endif
if (CFREG != MinStackGap*(stack_overflows+1))
if (CFREG != CalculateStackGap())
goto creepde;
NoStackExec:
@ -2041,10 +2041,10 @@ absmi(int inp)
/* no more goals to wake up */
UpdateTimedVar(WokenGoals, TermNil);
CFREG = MinStackGap*(stack_overflows+1);
CFREG = CalculateStackGap();
}
else {
CFREG = MinStackGap*(stack_overflows+1);
CFREG = CalculateStackGap();
/* We haven't changed P yet so this means redo the
* same instruction */
JMPNext();
@ -2101,7 +2101,7 @@ absmi(int inp)
ARG1 = (Term) AbsPair(H);
H += 2;
CFREG = MinStackGap*(stack_overflows+1);
CFREG = CalculateStackGap();
SREG = (CELL *) (Unsigned(CreepCode) - sizeof(SMALLUNSGN));
#ifdef COROUTINING
@ -5920,7 +5920,7 @@ absmi(int inp)
{
Prop p = GetPredProp (at, 1);
if (p == NIL) {
CFREG = MinStackGap*(stack_overflows+1);
CFREG = CalculateStackGap();
FAIL();
} else {
PredEntry *undefpe;
@ -5932,7 +5932,7 @@ absmi(int inp)
}
}
PREG = (yamop *)pred_entry_from_code(UndefCode)->CodeOfPred;
CFREG = MinStackGap*(stack_overflows+1);
CFREG = CalculateStackGap();
CACHE_A1();
JMPNext();
ENDBOp();
@ -10144,7 +10144,7 @@ absmi(int inp)
if (pt1+d1 > ENV || pt1+d1 > (CELL *)B) {
/* make sure we have something to show for our trouble */
saveregs();
gc(3, Y, NEXTOP(NEXTOP(PREG,xxx),sla));
gc(0, Y, NEXTOP(NEXTOP(PREG,xxx),sla));
setregs();
goto restart_func2s;
}
@ -10242,7 +10242,7 @@ absmi(int inp)
if (pt1+d1 > ENV || pt1+d1 > (CELL *)B) {
/* make sure we have something to show for our trouble */
saveregs();
gc(3, Y, NEXTOP(NEXTOP(PREG,xcx),sla));
gc(0, Y, NEXTOP(NEXTOP(PREG,xcx),sla));
setregs();
goto restart_func2s_cv;
}
@ -10339,7 +10339,7 @@ absmi(int inp)
if (pt1+d1 > ENV || pt1+d1 > (CELL *)B) {
/* make sure we have something to show for our trouble */
saveregs();
gc(3, Y, NEXTOP(NEXTOP(PREG,xxc),sla));
gc(0, Y, NEXTOP(NEXTOP(PREG,xxc),sla));
setregs();
goto restart_func2s_vc;
}
@ -10433,7 +10433,7 @@ absmi(int inp)
if (pt1+d1 > ENV || pt1+d1 > (CELL *)B) {
/* make sure we have something to show for our trouble */
saveregs();
gc(3, Y, NEXTOP(NEXTOP(PREG,yxx),sla));
gc(0, Y, NEXTOP(NEXTOP(PREG,yxx),sla));
setregs();
goto restart_func2s_y;
}
@ -10553,7 +10553,7 @@ absmi(int inp)
if (pt1+d1 > ENV || pt1+d1 > (CELL *)B) {
/* make sure we have something to show for our trouble */
saveregs();
gc(3, Y, NEXTOP(NEXTOP(PREG,ycx),sla));
gc(0, Y, NEXTOP(NEXTOP(PREG,ycx),sla));
setregs();
goto restart_func2s_y_cv;
}
@ -10682,7 +10682,7 @@ absmi(int inp)
if (pt1+d1 > ENV || pt1+d1 > (CELL *)B) {
/* make sure we have something to show for our trouble */
saveregs();
gc(3, Y, NEXTOP(NEXTOP(PREG,yxc),sla));
gc(0, Y, NEXTOP(NEXTOP(PREG,yxc),sla));
setregs();
goto restart_func2s_y_vc;
}

5
C/alloc.c
View File

@ -12,7 +12,7 @@
* Last rev: *
* mods: *
* comments: allocating space *
* version:$Id: alloc.c,v 1.6 2001-05-07 19:56:02 vsc Exp $ *
* version:$Id: alloc.c,v 1.7 2001-05-21 20:00:05 vsc Exp $ *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
@ -537,6 +537,7 @@ ExtendWorkSpace(Int s)
{
#ifdef YAPOR
abort_optyap("function ExtendWorkSpace called");
return(FALSE);
#else
MALLOC_T a;
@ -614,9 +615,9 @@ ExtendWorkSpace(Int s)
return FALSE;
}
#endif /* YAPOR */
WorkSpaceTop = (char *) a + s;
return TRUE;
#endif /* YAPOR */
}
int

3
C/attvar.c
View File

@ -199,6 +199,8 @@ CurrentTime(void) {
static Int
InitVarTime(void) {
return(0);
#ifdef BEFORE_TRAIL_COMPRESSION
if (B->cp_tr == TR) {
/* we run the risk of not making non-determinate bindings before
the end of the night */
@ -206,6 +208,7 @@ InitVarTime(void) {
Bind((CELL *)(TR+1),AbsAppl(H-1));
}
return((CELL *)(B->cp_tr)-(CELL *)TrailBase);
#endif
}
static Int

77
C/c_interface.c
View File

@ -81,6 +81,8 @@ X_API void *STD_PROTO(YapAllocSpaceFromYap,(unsigned int));
X_API void STD_PROTO(YapFreeSpaceFromYap,(void *));
X_API void STD_PROTO(YapFreeSpaceFromYap,(void *));
X_API int STD_PROTO(YapStringToBuffer, (Term, char *, unsigned int));
X_API Term STD_PROTO(YapBufferToString, (char *));
X_API Term STD_PROTO(YapBufferToAtomList, (char *));
X_API void STD_PROTO(YapError,(char *));
X_API int STD_PROTO(YapRunGoal,(Term));
X_API int STD_PROTO(YapRestartGoal,(void));
@ -96,6 +98,8 @@ X_API int STD_PROTO(YapReset, (void));
X_API void STD_PROTO(YapExit, (int));
X_API void STD_PROTO(YapInitSocks, (char *, long));
X_API void STD_PROTO(YapSetOutputMessage, (void));
X_API int STD_PROTO(YapStreamToFileNo, (Term));
X_API int STD_PROTO(YapPopen, (Term));
X_API Term
YapA(int i)
@ -359,12 +363,14 @@ YapUnify(Term pt1, Term pt2)
return(out);
}
Int YapExecute(CPredicate code)
Int
YapExecute(CPredicate code)
{
return((code)());
}
X_API Int YapCallProlog(Term t)
X_API Int
YapCallProlog(Term t)
{
Int out;
BACKUP_MACHINE_REGS();
@ -375,7 +381,8 @@ X_API Int YapCallProlog(Term t)
return(out);
}
X_API void *YapAllocSpaceFromYap(unsigned int size)
X_API void *
YapAllocSpaceFromYap(unsigned int size)
{
void *ptr;
BACKUP_MACHINE_REGS();
@ -391,13 +398,15 @@ X_API void *YapAllocSpaceFromYap(unsigned int size)
return(ptr);
}
X_API void YapFreeSpaceFromYap(void *ptr)
X_API void
YapFreeSpaceFromYap(void *ptr)
{
FreeCodeSpace(ptr);
}
/* copy a string to a buffer */
X_API int YapStringToBuffer(Term t, char *buf, unsigned int bufsize)
X_API int
YapStringToBuffer(Term t, char *buf, unsigned int bufsize)
{
unsigned int j = 0;
@ -419,7 +428,10 @@ X_API int YapStringToBuffer(Term t, char *buf, unsigned int bufsize)
return(FALSE);
}
buf[j++] = i;
if (j > bufsize) return(FALSE);
if (j > bufsize) {
buf[j-1] = '\0';
return(FALSE);
}
t = TailOfTerm(t);
if (IsVarTerm(t)) {
Error(INSTANTIATION_ERROR,t,"user defined procedure");
@ -434,6 +446,33 @@ X_API int YapStringToBuffer(Term t, char *buf, unsigned int bufsize)
}
/* copy a string to a buffer */
X_API Term
YapBufferToString(char *s)
{
Term t;
BACKUP_H();
t = StringToList(s);
RECOVER_H();
return(t);
}
/* copy a string to a buffer */
X_API Term
YapBufferToAtomList(char *s)
{
Term t;
BACKUP_H();
t = StringToListOfAtoms(s);
RECOVER_H();
return(t);
}
X_API void
YapError(char *buf)
{
@ -742,3 +781,29 @@ YapSetOutputMessage(void)
#endif
}
X_API int
YapStreamToFileNo(Term t)
{
return(StreamToFileNo(t));
}
X_API void
YapCloseAllOpenStreams(void)
{
BACKUP_H();
return(CloseStreams(FALSE));
RECOVER_H();
}
X_API Term
YapOpenStream(void *fh, char *name, Term nm, int flags)
{
BACKUP_H();
return(OpenStream((FILE *)fh, name, nm, flags));
RECOVER_H();
}

9
C/cdmgr.c
View File

@ -2032,6 +2032,7 @@ Int
PredForCode(CODEADDR codeptr, Atom *pat, Int *parity, SMALLUNSGN *pmodule) {
Int i_table;
Int val;
AtomEntry *chain;
for (i_table = 0; i_table < MaxHash; i_table++) {
Atom a;
@ -2048,6 +2049,14 @@ PredForCode(CODEADDR codeptr, Atom *pat, Int *parity, SMALLUNSGN *pmodule) {
}
READ_UNLOCK(HashChain[i_table].AERWLock);
}
chain = RepAtom(INVISIBLECHAIN.Entry);
while (!EndOfPAEntr(chain) != 0) {
if ((val = check_code_in_atom(chain, codeptr, parity, pmodule)) != 0) {
*pat = AbsAtom(chain);
return(val);
}
chain = RepAtom(chain->NextOfAE);
}
/* we didn't find it, must be one of the hidden predicates */
return(0);
}

23
C/compiler.c
View File

@ -329,7 +329,7 @@ optimize_ce(Term t, unsigned int arity)
CExpEntry *p = common_exps, *parent = common_exps;
int cmp = 0;
if (onbranch || (IsApplTerm(t) && IsExtensionFunctor(FunctorOfTerm(t))))
if (IsApplTerm(t) && IsExtensionFunctor(FunctorOfTerm(t)))
return (t);
while (p != NULL) {
CELL *OldH = H;
@ -1041,7 +1041,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3)
save_machine_regs();
longjmp(CompilerBotch,1);
}
} else if (IsNewVar(t3) && cur_branch == 0) {
} else if (IsNewVar(t3) /* && cur_branch == 0 */) {
c_var(t3,f_flag,(unsigned int)Op);
if (Op == _functor) {
emit(empty_call_op, Zero, Zero);
@ -2108,9 +2108,9 @@ CheckUnsafe(PInstr *pc)
add_bvarray_op(pc, vstat, pc->rnd2);
break;
case call_op:
emit(label_op, ++labelno, Zero);
pc->ops.opseqt[1] = (CELL)labelno;
add_bvarray_op(pc, vstat, pc->rnd2);
emit(label_op, ++labelno, Zero);
pc->ops.opseqt[1] = (CELL)labelno;
add_bvarray_op(pc, vstat, pc->rnd2);
case deallocate_op:
{
int n = pc->op == call_op ? pc->rnd2 : 0;
@ -2144,6 +2144,7 @@ CheckVoids(void)
cpc = CodeStart;
while ((ic = cpc->op) != allocate_op) {
ic = cpc->op;
#ifdef M_WILLIAMS
switch ((int) ic) {
#else
@ -2160,14 +2161,12 @@ CheckVoids(void)
ve = ((Ventry *) cpc->rnd1);
if ((ve->FlagsOfVE & PermFlag) == 0 && ve->RCountOfVE <= 1) {
ve->NoOfVE = ve->KindOfVE = VoidVar;
#ifndef SFUNC
if (ic == get_var_op || ic ==
save_pair_op || ic == save_appl_op) {
#else
if (ic == get_var_op || ic ==
save_appl_op || ic == save_pair_op
|| ic == unify_s_var_op) {
save_pair_op || ic == save_appl_op
#ifdef SFUNC
|| ic == unify_s_var_op
#endif
) {
cpc->op = nop_op;
break;
}
@ -2202,6 +2201,8 @@ checktemp(void)
vreg = vadr & MaskVarAdrs;
if (v->KindOfVE == PermVar || v->KindOfVE == VoidVar)
return (0);
if (v->RCountOfVE == 1)
return(0);
if (vreg) {
--Uses[vreg];
return (1);

2
C/dbase.c
View File

@ -1939,7 +1939,7 @@ GetDBTerm(DBRef DBSP)
pt = CellPtr(DBSP->Contents);
NOf = DBSP->NOfCells;
if (H+NOf > ASP - MinStackGap*(stack_overflows+1)) {
if (H+NOf > ASP-CalculateStackGap()) {
return((Term)0);
}
HeapPtr = cpcells(HOld, pt, NOf);

4
C/errors.c
View File

@ -255,7 +255,7 @@ Abort (char *format,...)
}
else
{
CreepFlag = MinStackGap*(stack_overflows+1);
CreepFlag = CalculateStackGap();
#if PUSH_REGS
restore_absmi_regs(&standard_regs);
#endif
@ -1801,7 +1801,7 @@ Error (yap_error_number type, Term where, char *format,...)
if (serious) {
Int depth;
CreepFlag = MinStackGap*(stack_overflows+1);
CreepFlag = CalculateStackGap();
if (type == PURE_ABORT)
depth = SetDBForThrow(MkAtomTerm(LookupAtom("abort")));
else

2
C/exec.c
View File

@ -845,7 +845,7 @@ exec_absmi(int top)
B = (choiceptr)(LCL0-depth);
#endif
yap_flags[SPY_CREEP_FLAG] = 0;
CreepFlag = MinStackGap*(stack_overflows+1);
CreepFlag = CalculateStackGap();
#if defined(__GNUC__) && defined(hppa)
/* siglongjmp resets the TR hardware register */
restore_TR();

4
C/grow.c
View File

@ -695,7 +695,7 @@ growstack(long size)
fix_tabling_info();
#endif
YAPLeaveCriticalSection();
CreepFlag = MinStackGap*(stack_overflows+1);
CreepFlag = CalculateStackGap();
ASP += 256;
growth_time = cputime()-start_growth_time;
total_stack_overflow_time += growth_time;
@ -815,7 +815,7 @@ growstack_in_parser(tr_fr_ptr *old_trp, TokEntry **tksp, VarEntry **vep)
}
AdjustRegs(MaxTemps);
YAPLeaveCriticalSection();
CreepFlag = MinStackGap*(stack_overflows+1);
CreepFlag = CalculateStackGap();
ASP += 256;
growth_time = cputime()-start_growth_time;
total_stack_overflow_time += growth_time;

345
C/heapgc.c
View File

@ -21,10 +21,12 @@ static char SccsId[] = "%W% %G%";
#include "absmi.h"
#include "yapio.h"
#define DEBUG 1
#define EARLY_RESET 1
#define EASY_SHUNTING 1
#define HYBRID_SCHEME 1
//#define HYBRID_SCHEME 1
#ifdef MULTI_ASSIGNMENT_VARIABLES
/*
@ -153,6 +155,8 @@ static choiceptr current_B;
static tr_fr_ptr sTR;
#endif
static tr_fr_ptr new_TR;
STATIC_PROTO(void push_registers, (Int, yamop *));
STATIC_PROTO(void marking_phase, (tr_fr_ptr, CELL *, yamop *, CELL *));
STATIC_PROTO(void compaction_phase, (tr_fr_ptr, CELL *, yamop *, CELL *));
@ -655,7 +659,7 @@ init_dbtable(tr_fr_ptr trail_ptr) {
#ifdef DEBUG
/*#define INSTRUMENT_GC 1*/
#define INSTRUMENT_GC 1
/*#define CHECK_CHOICEPOINTS 1*/
#ifdef INSTRUMENT_GC
@ -780,16 +784,25 @@ check_global(void) {
#if INSTRUMENT_GC
if (IsVarTerm(ccurr)) {
if (IsBlobFunctor((Functor)ccurr)) vars[gc_num]++;
else if (ccurr != 0 && ccurr < (CELL)HeapTop) vars[gc_func]++;
else if (ccurr != 0 && ccurr < (CELL)HeapTop) {
/* printf("%p: %s/%d\n", current,
RepAtom(NameOfFunctor((Functor)ccurr))->StrOfAE,
ArityOfFunctor((Functor)ccurr));*/
vars[gc_func]++;
}
else if (IsUnboundVar((CELL)current)) vars[gc_var]++;
else vars[gc_ref]++;
} else if (IsApplTerm(ccurr)) {
// printf("%p: f->%p\n",current,RepAppl(ccurr));
vars[gc_appl]++;
} else if (IsPairTerm(ccurr)) {
// printf("%p: l->%p\n",current,RepPair(ccurr));
vars[gc_list]++;
} else if (IsAtomTerm(ccurr)) {
// printf("%p: %s\n",current,RepAtom(AtomOfTerm(ccurr))->StrOfAE);
vars[gc_atom]++;
} else if (IsIntTerm(ccurr)) {
// printf("%p: %d\n",current,IntOfTerm(ccurr));
vars[gc_int]++;
}
#endif
@ -1202,12 +1215,18 @@ mark_trail(tr_fr_ptr trail_ptr, tr_fr_ptr trail_base, CELL *gc_H, choiceptr gc_B
mark_external_reference(&TrailTerm(trail_ptr));
UNMARK(&TrailTerm(trail_ptr));
#endif /* EARLY_RESET */
} else {
if (hp < (CELL *)HeapTop) {
} else if (hp < (CELL *)HeapTop) {
/* I decided to allow pointers from the Heap back into the trail.
The point of doing so is to have dynamic arrays */
mark_external_reference(hp);
}
mark_external_reference(hp);
} else if ((hp < (CELL *)gc_B && hp >= gc_H) || hp > (CELL *)TrailBase) {
/* clean the trail, avoid dangling pointers! */
RESET_VARIABLE(&TrailTerm(trail_ptr));
#ifdef FROZEN_REGS
RESET_VARIABLE(&TrailVal(trail_ptr));
#endif
discard_trail_entries++;
} else {
#ifdef EASY_SHUNTING
if (hp < gc_H && hp >= H0) {
CELL *cptr = (CELL *)trail_cell;
@ -1300,9 +1319,16 @@ mark_trail(tr_fr_ptr trail_ptr, tr_fr_ptr trail_base, CELL *gc_H, choiceptr gc_B
#if MULTI_ASSIGNMENT_VARIABLES
while (live_list != NULL) {
CELL trail_cell = TrailTerm(live_list->trptr-1);
CELL trail_cell2 = TrailTerm(live_list->trptr);
if (HEAP_PTR(trail_cell)) {
mark_external_reference(&TrailTerm(live_list->trptr-1));
}
/*
swap the two so that the sweep_trail() knows we have
a multi-assignment binding
*/
TrailTerm(live_list->trptr) = TrailTerm(live_list->trptr-1);
TrailTerm(live_list->trptr-1) = trail_cell2;
live_list = live_list->ma_list;
}
#endif
@ -1325,10 +1351,6 @@ mark_trail(tr_fr_ptr trail_ptr, tr_fr_ptr trail_base, CELL *gc_H, choiceptr gc_B
#endif /* TABLING_SCHEDULING */
#endif
#ifdef DEBUG
//#define CHECK_CHOICEPOINTS 1
#endif
#ifdef CHECK_CHOICEPOINTS
#ifndef ANALYST
@ -1379,7 +1401,15 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR)
case _retry_userc:
case _trust_logical_pred:
case _retry_profiled:
printf("B %p (%s) with %d\n", gc_B, op_names[opnum], total_marked);
{
Atom at;
UInt arity;
SMALLUNSGN mod;
if (PredForCode((CODEADDR)gc_B->cp_ap, &at, &arity, &mod))
printf("B %p (%s) at %s/%d with %d,%d\nf", gc_B, op_names[opnum], RepAtom(at)->StrOfAE, arity, gc_B->cp_h-H0, total_marked);
else
printf("B %p (%s) with %d,%d\n", gc_B, op_names[opnum], gc_B->cp_h-H0, total_marked);
}
break;
#ifdef TABLING
case _table_completion:
@ -1389,11 +1419,11 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR)
op_numbers caller_op = op_from_opcode(ENV_ToOp(gc_B->cp_cp));
/* first condition checks if this was a meta-call */
if ((caller_op != _call && caller_op != _fcall) || pe == NULL) {
printf("B %p (%s) with %d\n", gc_B, op_names[opnum], total_marked);
printf("B %p (%s) with %d,%d\n", gc_B, op_names[opnum], gc_B->cp_h-H0, total_marked);
} else if (pe->ArityOfPE)
printf("B %p (%s for %s/%d) with %d\n", gc_B, op_names[opnum], RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE, total_marked);
printf("B %p (%s for %s/%d) with %d,%d\n", gc_B, op_names[opnum], RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE, gc_B->cp_h-H0, total_marked);
else
printf("B %p (%s for %s/0) with %d\n", gc_B, op_names[opnum], RepAtom((Atom)(pe->FunctorOfPred))->StrOfAE, total_marked);
printf("B %p (%s for %s/0) with %d,%d\n", gc_B, op_names[opnum], RepAtom((Atom)(pe->FunctorOfPred))->StrOfAE, gc_B->cp_h-H0, total_marked);
}
break;
#endif
@ -1403,14 +1433,21 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR)
if (pe == NULL) {
printf("B %p (%s) with %d\n", gc_B, op_names[opnum], total_marked);
} else if (pe->ArityOfPE)
printf("B %p (%s for %s/%d) with %d\n", gc_B, op_names[opnum], RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE, total_marked);
printf("B %p (%s for %s/%d) with %d,%d\n", gc_B, op_names[opnum], RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE, gc_B->cp_h-H0, total_marked);
else
printf("B %p (%s for %s/0) with %d\n", gc_B, op_names[opnum], RepAtom((Atom)(pe->FunctorOfPred))->StrOfAE, total_marked);
printf("B %p (%s for %s/0) with %d,%d\n", gc_B, op_names[opnum], RepAtom((Atom)(pe->FunctorOfPred))->StrOfAE, gc_B->cp_h-H0, total_marked);
}
}
#endif /* CHECK_CHOICEPOINTS */
mark_trail(saved_TR, gc_B->cp_tr, gc_B->cp_h, gc_B);
saved_TR = gc_B->cp_tr;
{
/* find out how many cells are still alive in the trail */
UInt d0 = discard_trail_entries, diff, orig;
orig = saved_TR-gc_B->cp_tr;
mark_trail(saved_TR, gc_B->cp_tr, gc_B->cp_h, gc_B);
saved_TR = gc_B->cp_tr;
diff = discard_trail_entries-d0;
gc_B->cp_tr = (tr_fr_ptr)(orig-diff);
}
restart_cp:
if (opnum == _or_else || opnum == _or_last) {
/* ; choice point */
@ -1640,15 +1677,26 @@ into_relocation_chain(CELL_PTR current, CELL_PTR next)
static void
sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR)
{
tr_fr_ptr trail_ptr;
CELL *cp_H = gc_B->cp_h;
tr_fr_ptr trail_ptr, dest, tri = (tr_fr_ptr)db_vec;
Int OldHeapUsed = HeapUsed;
#ifdef DEBUG
Int hp_entrs = 0, hp_erased = 0, hp_not_in_use = 0,
hp_in_use_erased = 0, code_entries = 0;
#endif
#if MULTI_ASSIGNMENT_VARIABLES
tr_fr_ptr next_timestamp = NULL;
#endif
/* adjust cp_tr pointers */
{
Int size = old_TR-(tr_fr_ptr)TrailBase;
size -= discard_trail_entries;
while (gc_B != NULL) {
size -= (UInt)(gc_B->cp_tr);
gc_B->cp_tr = (tr_fr_ptr)TrailBase+size;
gc_B = gc_B->cp_b;
}
}
#if DB_SEARCH_METHOD
#if DEBUG
{
@ -1671,129 +1719,173 @@ sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR)
}
/* next, follows the real trail entries */
trail_ptr = old_TR;
while (trail_ptr > (tr_fr_ptr)TrailBase) {
trail_ptr = (tr_fr_ptr)TrailBase;
dest = trail_ptr;
while (trail_ptr < old_TR) {
register CELL trail_cell;
trail_ptr--;
trail_cell = TrailTerm(trail_ptr);
if (gc_B && trail_ptr < gc_B->cp_tr) {
do {
gc_B = gc_B->cp_b;
} while (gc_B && trail_ptr < gc_B->cp_tr);
cp_H = gc_B->cp_h;
}
if (IsVarTerm(trail_cell)) {
/* we need to check whether this is a honest to god trail entry */
if ((CELL *)trail_cell < cp_H && MARKED(*(CELL *)trail_cell) && (CELL *)trail_cell >= H0) {
if (HEAP_PTR(trail_cell)) {
into_relocation_chain(&TrailTerm(trail_ptr), GET_NEXT(trail_cell));
}
} else if ((CELL *)trail_cell < (CELL *)HeapTop) {
/* we may have pointers from the heap back into the cell */
UNMARK(CellPtr(trail_cell));
if (HEAP_PTR(trail_cell)) {
into_relocation_chain(CellPtr(trail_cell), GET_NEXT(*(CELL *)trail_cell));
}
} else {
/* clean the trail, avoid dangling pointers! */
if ((CELL *)trail_cell < (CELL *)gc_B && (CELL *)trail_cell >= H0) {
RESET_VARIABLE(&TrailTerm(trail_ptr));
if (trail_cell == (CELL)trail_ptr) {
trail_ptr++;
/* just skip cell */
} else {
TrailTerm(dest) = trail_cell;
#ifdef FROZEN_REGS
RESET_VARIABLE(&TrailVal(trail_ptr));
TrailVal(dest) = TrailVal(trail_ptr);
#endif
discard_trail_entries++;
if (IsVarTerm(trail_cell)) {
/* we need to check whether this is a honest to god trail entry */
if ((CELL *)trail_cell < H && MARKED(*(CELL *)trail_cell) && (CELL *)trail_cell >= H0) {
if (HEAP_PTR(trail_cell)) {
into_relocation_chain(&TrailTerm(dest), GET_NEXT(trail_cell));
}
} else if ((CELL *)trail_cell < (CELL *)HeapTop) {
/* we may have pointers from the heap back into the cell */
UNMARK(CellPtr(trail_cell));
if (HEAP_PTR(trail_cell)) {
into_relocation_chain(CellPtr(trail_cell), GET_NEXT(*(CELL *)trail_cell));
}
}
}
#ifdef FROZEN_REGS
if (MARKED(TrailVal(trail_ptr))) {
UNMARK(&TrailVal(trail_ptr));
if (HEAP_PTR(TrailVal(trail_ptr))) {
into_relocation_chain(&TrailVal(trail_ptr), GET_NEXT(TrailVal(trail_ptr)));
if (MARKED(TrailVal(dest))) {
UNMARK(&TrailVal(dest));
if (HEAP_PTR(TrailVal(dest))) {
into_relocation_chain(&TrailVal(dest), GET_NEXT(TrailVal(dest)));
}
}
}
#endif
} else if (IsPairTerm(trail_cell)) {
CELL *pt0 = RepPair(trail_cell);
CELL flags;
} else if (IsPairTerm(trail_cell)) {
CELL *pt0 = RepPair(trail_cell);
CELL flags;
#ifdef FROZEN_REGS /* TRAIL */
/* process all segments */
if (
/* process all segments */
if (
#ifdef SBA
(ADDR) pt0 >= HeapTop
(ADDR) pt0 >= HeapTop
#else
(ADDR) pt0 >= TrailBase
(ADDR) pt0 >= TrailBase
#endif
) {
continue;
}
) {
continue;
}
#endif /* FROZEN_REGS */
flags = Flags((CELL)pt0);
flags = Flags((CELL)pt0);
#ifdef DEBUG
if (FlagOn(DBClMask, flags) && !FlagOn(LogUpdMask, flags)) {
hp_entrs++;
if (!FlagOn(GcFoundMask, flags)) {
hp_not_in_use++;
if (FlagOn(ErasedMask, flags)) {
hp_erased++;
if (FlagOn(DBClMask, flags) && !FlagOn(LogUpdMask, flags)) {
hp_entrs++;
if (!FlagOn(GcFoundMask, flags)) {
hp_not_in_use++;
if (FlagOn(ErasedMask, flags)) {
hp_erased++;
}
} else {
if (FlagOn(ErasedMask, flags)) {
hp_in_use_erased++;
}
}
} else {
if (FlagOn(ErasedMask, flags)) {
hp_in_use_erased++;
}
code_entries++;
}
} else {
code_entries++;
}
#endif
if (!FlagOn(GcFoundMask, flags)) {
if (FlagOn(DBClMask, flags) && !FlagOn(LogUpdMask, flags)) {
Flags((CELL)pt0) = ResetFlag(InUseMask, flags);
if (FlagOn(ErasedMask, flags)) {
ErDBE((DBRef) ((CELL)pt0 - (CELL) &(((DBRef) NIL)->Flags)));
if (!FlagOn(GcFoundMask, flags)) {
if (FlagOn(DBClMask, flags) && !FlagOn(LogUpdMask, flags)) {
Flags((CELL)pt0) = ResetFlag(InUseMask, flags);
if (FlagOn(ErasedMask, flags)) {
ErDBE((DBRef) ((CELL)pt0 - (CELL) &(((DBRef) NIL)->Flags)));
}
RESET_VARIABLE(&TrailTerm(dest));
discard_trail_entries++;
}
RESET_VARIABLE(trail_ptr);
discard_trail_entries++;
} else {
Flags((CELL)pt0) = ResetFlag(GcFoundMask, flags);
}
} else {
Flags((CELL)pt0) = ResetFlag(GcFoundMask, flags);
}
#if MULTI_ASSIGNMENT_VARIABLES
} else {
CELL *old_value_ptr = (CELL *)trail_ptr;
} else {
CELL trail_cell = TrailTerm(trail_ptr);
CELL *ptr;
CELL old = TrailTerm(trail_ptr+1);
if (MARKED(trail_cell)) {
UNMARK(&TrailTerm(trail_ptr));
if (HEAP_PTR(TrailTerm(trail_ptr))) {
into_relocation_chain(&TrailTerm(trail_ptr), GET_NEXT(trail_cell));
if (MARKED(trail_cell))
ptr = RepAppl(UNMARK_CELL(trail_cell));
else
ptr = RepAppl(trail_cell);
/* now, we must check whether we are looking at a time-stamp */
if (next_timestamp == trail_ptr) {
/* we have a time stamp. Problem is: the trail shifted and we can not trust the
current time stamps */
CELL old_cell = *ptr;
int was_marked = MARKED(old_cell);
tr_fr_ptr old_timestamp;
if (was_marked)
old_cell = UNMARK_CELL(old_cell);
old_timestamp = (tr_fr_ptr)TrailBase+IntegerOfTerm(old_cell);
if (old_timestamp >= trail_ptr) {
/* first time, we found the current timestamp */
old = MkIntTerm(0);
} else {
/* set time stamp to current */
old = old_cell;
}
*ptr = MkIntegerTerm(dest-(tr_fr_ptr)TrailBase);
if (was_marked)
MARK(ptr);
} else if (ptr < H0 || UNMARK_CELL(ptr[-1]) == (CELL)FunctorMutable) {
/* yes, we do have a time stamp */
next_timestamp = trail_ptr+2;
}
}
trail_cell = old_value_ptr[-1];
TrailTerm(dest) = old;
TrailTerm(dest+1) = trail_cell;
if (MARKED(old)) {
UNMARK(&TrailTerm(dest));
if (HEAP_PTR(old)) {
into_relocation_chain(&TrailTerm(dest), GET_NEXT(old));
}
}
dest++;
if (MARKED(trail_cell)) {
UNMARK(&TrailTerm(dest));
if (HEAP_PTR(trail_cell)) {
if (next_timestamp == trail_ptr) {
/* wait until we're over to insert in relocation chain */
TrailTerm(tri) = (CELL)dest;
tri++;
} else {
into_relocation_chain(&TrailTerm(dest), GET_NEXT(trail_cell));
}
}
}
trail_ptr++;
#ifdef FROZEN_REGS
if (MARKED(TrailVal(trail_ptr))) {
UNMARK(&TrailVal(trail_ptr));
if (HEAP_PTR(TrailVal(trail_ptr))) {
into_relocation_chain(&TrailVal(trail_ptr), GET_NEXT(TrailTerm(trail_ptr)));
TrailVal(dest) = TrailVal(trail_ptr);
if (MARKED(TrailVal(dest))) {
UNMARK(&TrailVal(dest));
if (HEAP_PTR(TrailVal(dest))) {
into_relocation_chain(&TrailVal(dest), GET_NEXT(TrailTerm(dest)));
}
}
}
#endif
old_value_ptr--;
if (MARKED(trail_cell)) {
UNMARK(old_value_ptr);
if (HEAP_PTR(trail_cell)) {
into_relocation_chain(old_value_ptr, GET_NEXT(trail_cell));
}
}
trail_ptr = (tr_fr_ptr)old_value_ptr;
#endif
}
trail_ptr++;
dest++;
}
}
while (tri > (tr_fr_ptr)db_vec) {
tr_fr_ptr x = (tr_fr_ptr)TrailTerm(--tri);
CELL trail_cell = TrailTerm(x);
if (HEAP_PTR(trail_cell)) {
into_relocation_chain(&TrailTerm(x), GET_NEXT(trail_cell));
}
}
new_TR = dest;
if (is_gc_verbose()) {
YP_fprintf(YP_stderr,
"[GC] Trail: discarded %d (%ld%%) cells out of %ld\n",
@ -2502,7 +2594,7 @@ icompact_heap(void)
#ifdef EASY_SHUNTING
static void
set_conditionals(CELL *TRo) {
set_conditionals(tr_fr_ptr TRo) {
while (sTR != TRo) {
CELL *cptr = (CELL *)TrailTerm(sTR-1);
*cptr = TrailTerm(sTR-2);
@ -2580,10 +2672,10 @@ compaction_phase(tr_fr_ptr old_TR, CELL *current_env, yamop *curp, CELL *max)
if (total_marked != iptop-(CELL_PTR *)H && iptop < (CELL_PTR *)ASP -1024)
YP_fprintf(YP_stderr,"[GC] Oops on iptop-H (%d) vs %d\n", iptop-(CELL_PTR *)H, total_marked);
#endif
if (iptop < (CELL_PTR *)ASP-1024 && 10*total_marked < H-H0) {
if (iptop < (CELL_PTR *)ASP /* && 10*total_marked < H-H0 */) {
int effectiveness = (((H-H0)-total_marked)*100)/(H-H0);
#ifdef DEBUG
fprintf(stderr,"using pointers (%d)\n", effectiveness);
YP_fprintf(YP_stderr,"[GC] using pointers (%d)\n", effectiveness);
#endif
quicksort((CELL_PTR *)H, 0, (iptop-(CELL_PTR *)H)-1);
adjust_cp_hbs();
@ -2591,9 +2683,11 @@ compaction_phase(tr_fr_ptr old_TR, CELL *current_env, yamop *curp, CELL *max)
} else
#endif /* HYBRID_SCHEME */
{
#ifdef DEBUG_IN
#ifdef DEBUG
#ifdef HYBID_SCHEME
int effectiveness = (((H-H0)-total_marked)*100)/(H-H0);
fprintf(stderr,"not using pointers (%d)\n", effectiveness);
fprintf(stderr,"[GC] not using pointers (%d) ASP: %p, ip %p (expected %p) \n", effectiveness, ASP, iptop, H+total_marked);
#endif
#endif
compact_heap();
}
@ -2690,6 +2784,7 @@ do_gc(Int predarity, CELL *current_env, yamop *nextop)
compaction_phase(old_TR, current_env, nextop, max);
TR = old_TR;
pop_registers(predarity, nextop);
TR = new_TR;
c_time = cputime();
YAPLeaveCriticalSection();
if (gc_verbose) {
@ -2714,7 +2809,12 @@ do_gc(Int predarity, CELL *current_env, yamop *nextop)
int
is_gc_verbose(void)
{
#ifdef INSTRUMENT_GC
/* always give info when we are debugging gc */
return(TRUE);
#else
return(GetValue(AtomGcVerbose) != TermNil);
#endif
}
Int total_gc_time(void)
@ -2765,20 +2865,21 @@ gc(Int predarity, CELL *current_env, yamop *nextop)
gc_margin <<= 1;
}
/* expand the stak if effectiveness is less than 20 % */
if (ASP - H < gc_margin || !gc_on || effectiveness < 20) {
if (FALSE&& ASP - H < gc_margin || !gc_on || effectiveness < 20) {
UInt gap = CalculateStackGap();
if (ASP-H > gc_margin)
gc_margin = (ASP-H)+MinStackGap*(stack_overflows+1);
gc_margin = (ASP-H)+gap;
else
gc_margin = 8 * (gc_margin - (ASP - H));
gc_margin = ((gc_margin >> 16) + 1) << 16;
if (gc_margin < MinStackGap)
gc_margin = MinStackGap;
while (gc_margin >= MinStackGap && !growstack(gc_margin))
if (gc_margin < gap)
gc_margin = gap;
while (gc_margin >= gap && !growstack(gc_margin))
gc_margin = gc_margin/2;
#ifdef DEBUG
check_global();
#endif
return(gc_margin >= MinStackGap);
return(gc_margin >= gap);
}
/*
* debug for(save_total=1; save_total<=N; ++save_total)

2
C/init.c
View File

@ -1015,6 +1015,7 @@ InitYaamRegs(void)
BBREG = B_FZ = B_BASE;
TR = TR_FZ = TR_BASE;
#endif /* FROZEN_REGS */
CreepFlag = CalculateStackGap();
}
@ -1124,7 +1125,6 @@ InitStacks(int Heap,
ReleaseAtom(AtomFoundVar);
LookupAtomWithAddress("[]",&(SF_STORE->AtNil));
LookupAtomWithAddress(".",&(SF_STORE->AtDot));
CreepFlag = MinStackGap;
PutValue(LookupAtom("$catch_counter"),
MkIntTerm(0));
/* InitAbsmi must be done before InitCodes */

359
C/iopreds.c
View File

@ -82,6 +82,9 @@ typedef struct
Int max_size; /* maximum buffer size (may be changed dynamically) */
Int pos;
} mem_string;
struct {
int fd;
} pipe;
#if USE_SOCKET
struct {
socket_domain domain;
@ -111,6 +114,8 @@ STATIC_PROTO (int post_process_read_char, (int, StreamDesc *, int));
STATIC_PROTO (int SocketPutc, (int, int));
STATIC_PROTO (int ConsoleSocketPutc, (int, int));
#endif
STATIC_PROTO (int PipePutc, (int, int));
STATIC_PROTO (int ConsolePipePutc, (int, int));
STATIC_PROTO (int NullPutc, (int, int));
STATIC_PROTO (int ConsolePutc, (int, int));
STATIC_PROTO (Int p_setprompt, (void));
@ -119,6 +124,8 @@ STATIC_PROTO (int PlGetc, (int));
STATIC_PROTO (int MemGetc, (int));
STATIC_PROTO (int ISOGetc, (int));
STATIC_PROTO (int ConsoleGetc, (int));
STATIC_PROTO (int PipeGetc, (int));
STATIC_PROTO (int ConsolePipeGetc, (int));
#if USE_SOCKET
STATIC_PROTO (int SocketGetc, (int));
STATIC_PROTO (int ConsoleSocketGetc, (int));
@ -214,6 +221,8 @@ StreamDesc Stream[MaxStreams];
#define Server_Socket_Stream_f 0x010000
#endif
#define InMemory_Stream_f 0x020000
#define Pipe_Stream_f 0x040000
#define Popen_Stream_f 0x080000
int YP_stdin = 0;
int YP_stdout = 1;
@ -276,7 +285,7 @@ YP_putc(int ch, int sno)
int
YP_fflush(int sno)
{
if (Stream[sno].status & (Null_Stream_f|InMemory_Stream_f|Socket_Stream_f))
if (Stream[sno].status & (Null_Stream_f|InMemory_Stream_f|Socket_Stream_f|Pipe_Stream_f))
return(0);
return(fflush(Stream[sno].u.file.file));
}
@ -376,7 +385,11 @@ InitStdStream (int sno, SMALLUNSGN flags, YP_File file, Atom name)
s->stream_getc = ConsoleSocketGetc;
} else
#endif
if (s->status & InMemory_Stream_f) {
if (s->status & Pipe_Stream_f) {
/* Console is a socket and socket will prompt */
s->stream_putc = ConsolePipePutc;
s->stream_getc = ConsolePipeGetc;
} else if (s->status & InMemory_Stream_f) {
s->stream_putc = MemPutc;
s->stream_getc = MemGetc;
} else {
@ -629,8 +642,42 @@ SocketPutc (int sno, int ch)
console_count_output_char(ch,s,sno);
return ((int) ch);
}
#endif
/* static */
static int
ConsolePipePutc (int sno, int ch)
{
StreamDesc *s = &Stream[sno];
char c = ch;
#if MAC || _MSC_VER
if (ch == 10)
{
ch = '\n';
}
#endif
write(s->u.pipe.fd, &c, sizeof(c));
count_output_char(ch,s,sno);
return ((int) ch);
}
static int
PipePutc (int sno, int ch)
{
StreamDesc *s = &Stream[sno];
char c = ch;
#if MAC || _MSC_VER
if (ch == 10)
{
ch = '\n';
}
#endif
write(s->u.pipe.fd, &c, sizeof(c));
console_count_output_char(ch,s,sno);
return ((int) ch);
}
static int
NullPutc (int sno, int ch)
{
@ -793,7 +840,12 @@ EOFGetc(int sno)
s->stream_putc = SocketPutc;
} else
#endif
if (s->status & InMemory_Stream_f) {
if (s->status & Pipe_Stream_f) {
if (s->status & Promptable_Stream_f)
s->stream_putc = ConsolePipePutc;
else
s->stream_putc = PipePutc;
} else if (s->status & InMemory_Stream_f) {
s->stream_getc = MemGetc;
s->stream_putc = MemPutc;
} else if (s->status & Promptable_Stream_f) {
@ -946,6 +998,61 @@ ConsoleSocketGetc(int sno)
}
#endif
static int
PipeGetc(int sno)
{
register StreamDesc *s = &Stream[sno];
register int ch;
char c;
int count;
/* should be able to use a buffer */
count = read(s->u.pipe.fd, &c, sizeof(char));
if (count == 0) {
ch = EOF;
} else if (count > 0) {
ch = c;
} else {
Error(SYSTEM_ERROR, TermNil, "read");
return(EOF);
}
return(post_process_read_char(ch, s, sno));
}
/*
Basically, the same as console but also sends a prompt and takes care of
finding out whether we are at the start of a newline.
*/
static int
ConsolePipeGetc(int sno)
{
register StreamDesc *s = &Stream[sno];
register int ch;
char c;
int count;
/* send the prompt away */
if (newline) {
char *cptr = Prompt, ch;
/* use the default routine */
while ((ch = *cptr++) != '\0') {
Stream[StdErrStream].stream_putc(StdErrStream, ch);
}
strncpy(Prompt, RepAtom (*AtPrompt)->StrOfAE, MAX_PROMPT);
newline = FALSE;
}
/* should be able to use a buffer */
count = read(s->u.pipe.fd, &c, sizeof(char));
if (count == 0) {
ch = EOF;
} else if (count > 0) {
ch = c;
} else {
Error(SYSTEM_ERROR, TermNil, "read");
return(EOF);
}
return(console_post_process_read_char(ch, s, sno));
}
/* standard routine, it should read from anything pointed by a FILE *.
It could be made more efficient by doing our own buffering and avoiding
post_process_read_char, something to think about */
@ -1132,7 +1239,9 @@ GetStreamFd(int sno)
return(Stream[sno].u.socket.fd);
} else