From e509d11c2e3938cf614c4431340bfeb7a106eea7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Mon, 1 Nov 2010 20:11:28 +0000 Subject: [PATCH] routines to copy rational terms to tree and vice-versa. --- C/utilpreds.c | 622 ++++++++++++++++++++++++++++++++++++++++++++++++++ H/TermExt.h | 1 - H/iatoms.h | 2 + H/ratoms.h | 2 + H/tatoms.h | 4 + docs/yap.tex | 18 ++ misc/ATOMS | 2 + 7 files changed, 650 insertions(+), 1 deletion(-) diff --git a/C/utilpreds.c b/C/utilpreds.c index 4b4a0e485..5e5efe7b4 100644 --- a/C/utilpreds.c +++ b/C/utilpreds.c @@ -540,6 +540,626 @@ p_copy_term_no_delays(void) /* copy term t to a new instance */ return(Yap_unify(ARG2,t)); } +typedef struct copy_frame { + CELL *start_cp; + CELL *end_cp; + CELL *to; +#ifdef RATIONAL_TREES + CELL oldv; + CELL *parent; + int ground; +#endif +} copy_frame_t; + +static int +break_rationals_complex_term(CELL *pt0, CELL *pt0_end, CELL *ptf, CELL *HLow) +{ + + struct copy_frame *to_visit0, *to_visit = (struct copy_frame *)Yap_PreAllocCodeSpace(); + CELL *HB0 = HB; + tr_fr_ptr TR0 = TR; + int ground = TRUE; + CELL *parent = ptf; + + HB = HLow; + to_visit0 = to_visit; + loop: + while (pt0 < pt0_end) { + register CELL d0; + register CELL *ptd0; + ++ pt0; + ptd0 = pt0; + d0 = *ptd0; + deref_head(d0, break_rationals_unk); + break_rationals_nvar: + { + if (IsPairTerm(d0)) { + CELL *ap2 = RepPair(d0); + if (ap2 >= HB && ap2 < H) { + /* If this is newer than the current term, just reuse */ + *ptf++ = d0; + continue; + } + *ptf = AbsPair(H); + ptf++; +#ifdef RATIONAL_TREES + if (to_visit+1 >= (struct copy_frame *)AuxSp) { + goto heap_overflow; + } + to_visit->start_cp = pt0; + to_visit->end_cp = pt0_end; + to_visit->to = ptf; + to_visit->oldv = *pt0; + to_visit->ground = ground; + to_visit->parent = parent; + parent = ptf-1; + /* fool the system into thinking we had a variable there */ + *pt0 = TermFoundVar; + to_visit ++; +#else + if (pt0 < pt0_end) { + if (to_visit+1 >= (struct copy_frame *)AuxSp) { + goto heap_overflow; + } + to_visit->start_cp = pt0; + to_visit->end_cp = pt0_end; + to_visit->to = ptf; + to_visit->ground = ground; + to_visit ++; + } +#endif + ground = TRUE; + pt0 = ap2 - 1; + pt0_end = ap2 + 1; + ptf = H; + H += 2; + if (H > ASP - 2048) { + goto overflow; + } + } else if (IsApplTerm(d0)) { + register Functor f; + register CELL *ap2; + /* store the terms to visit */ + ap2 = RepAppl(d0); + if (ap2 >= HB && ap2 <= H) { + /* If this is newer than the current term, just reuse */ + *ptf++ = d0; + continue; + } + f = (Functor)(*ap2); + + if (IsExtensionFunctor(f)) { + *ptf++ = d0; /* you can just copy extensions, what about DB?*/ + continue; + } + *ptf = AbsAppl(H); + ptf++; + /* store the terms to visit */ +#ifdef RATIONAL_TREES + if (to_visit+1 >= (struct copy_frame *)AuxSp) { + goto heap_overflow; + } + to_visit->start_cp = pt0; + to_visit->end_cp = pt0_end; + to_visit->to = ptf; + to_visit->oldv = *pt0; + to_visit->ground = ground; + to_visit->parent = parent; + parent = ptf-1; + /* fool the system into thinking we had a variable there */ + *pt0 = TermFoundVar; + to_visit ++; +#else + if (pt0 < pt0_end) { + if (to_visit+1 >= (struct copy_frame *)AuxSp) { + goto heap_overflow; + } + to_visit->start_cp = pt0; + to_visit->end_cp = pt0_end; + to_visit->to = ptf; + to_visit->ground = ground; + to_visit ++; + } +#endif + d0 = ArityOfFunctor(f); + pt0 = ap2; + pt0_end = ap2 + d0; + /* store the functor for the new term */ + H[0] = (CELL)f; + ptf = H+1; + H += 1+d0; + if (H > ASP - 2048) { + goto overflow; + } + } else { + /* just copy atoms or integers */ + if (d0 == TermFoundVar) { + struct copy_frame *visited = to_visit-1; + CELL *end = pt0_end; + RESET_VARIABLE(ptf); + while (visited >= to_visit0) { + if (visited->end_cp == end) { + Term t[1]; + t[0] = MkIntegerTerm(to_visit-visited); + *parent = Yap_MkApplTerm(FunctorLOOP,1,t); + break; + } + visited--; + } + ptf++; + ground = FALSE; + } else { + *ptf++ = d0; + } + } + continue; + } + + derefa_body(d0, ptd0, break_rationals_unk, break_rationals_nvar); + /* we have already found this cell */ + *ptf++ = (CELL) ptd0; + } + /* Do we still have compound terms to visit */ + if (to_visit > to_visit0) { + to_visit --; + if (ground) { + CELL old = to_visit->oldv; + CELL *newp = to_visit->to-1; + CELL new = *newp; + + *newp = old; + if (IsApplTerm(new)) + H = RepAppl(new); + else + H = RepPair(new); + } + pt0 = to_visit->start_cp; + pt0_end = to_visit->end_cp; + ptf = to_visit->to; + parent = to_visit->parent; +#ifdef RATIONAL_TREES + *pt0 = to_visit->oldv; +#endif + ground = (ground && to_visit->ground); + goto loop; + } + + /* restore our nice, friendly, term to its original state */ + clean_dirty_tr(TR0); + HB = HB0; + return ground; + + overflow: + /* oops, we're in trouble */ + H = HLow; + /* we've done it */ + /* restore our nice, friendly, term to its original state */ + HB = HB0; +#ifdef RATIONAL_TREES + while (to_visit > to_visit0) { + to_visit --; + pt0 = to_visit->start_cp; + pt0_end = to_visit->end_cp; + ptf = to_visit->to; + parent = to_visit->parent; + *pt0 = to_visit->oldv; + } +#endif + reset_trail(TR0); + /* follow chain of multi-assigned variables */ + return -1; + + heap_overflow: + /* oops, we're in trouble */ + H = HLow; + /* we've done it */ + /* restore our nice, friendly, term to its original state */ + HB = HB0; +#ifdef RATIONAL_TREES + while (to_visit > to_visit0) { + to_visit --; + pt0 = to_visit->start_cp; + pt0_end = to_visit->end_cp; + ptf = to_visit->to; + parent = to_visit->parent; + *pt0 = to_visit->oldv; + } +#endif + reset_trail(TR0); + Yap_Error_Size = (ADDR)AuxSp-(ADDR)to_visit0; + return -3; +} + + +static Term +BreakRational(Term inp, UInt arity) { + Term t = Deref(inp); + tr_fr_ptr TR0 = TR; + + if (IsVarTerm(t)) { + return t; + } else if (IsPrimitiveTerm(t)) { + return t; + } else if (IsPairTerm(t)) { + Term tf; + CELL *ap; + CELL *Hi; + + restart_list: + ap = RepPair(t); + Hi = H; + tf = AbsPair(H); + H += 2; + { + int res; + if ((res = break_rationals_complex_term(ap-1, ap+1, Hi, Hi)) < 0) { + H = Hi; + if ((t = handle_cp_overflow(res, TR0, arity, t))== 0L) + return FALSE; + goto restart_list; + } else if (res) { + H = Hi; + return t; + } + } + return tf; + } else { + Functor f = FunctorOfTerm(t); + Term tf; + CELL *HB0; + CELL *ap; + + restart_appl: + f = FunctorOfTerm(t); + HB0 = H; + ap = RepAppl(t); + tf = AbsAppl(H); + H[0] = (CELL)f; + H += 1+ArityOfFunctor(f); + if (H > ASP-128) { + H = HB0; + if ((t = handle_cp_overflow(-1, TR0, arity, t))== 0L) + return FALSE; + goto restart_appl; + } else { + int res; + + if ((res = break_rationals_complex_term(ap, ap+ArityOfFunctor(f), HB0+1, HB0)) < 0) { + H = HB0; + if ((t = handle_cp_overflow(res, TR0, arity, t))== 0L) + return FALSE; + goto restart_appl; + } else if (res && FunctorOfTerm(t) != FunctorMutable) { + H = HB0; + return t; + } + } + return tf; + } +} + +static Int +p_break_rational(void) +{ + return Yap_unify(ARG2, BreakRational(ARG1, 2)); +} + + +typedef struct restore_frame { + CELL *start_cp; + CELL *end_cp; + CELL *to; +#ifdef RATIONAL_TREES + CELL oldv; + CELL *parent; + int ground; + int term_type; +#endif +} restore_frame_t; + +static int +restore_rationals_complex_term(CELL *pt0, CELL *pt0_end, CELL *ptf, CELL *HLow, int pair) +{ + + struct restore_frame *to_visit0, *to_visit = (struct restore_frame *)Yap_PreAllocCodeSpace(); + CELL *HB0 = HB; + tr_fr_ptr TR0 = TR; + int ground = TRUE; + CELL *parent = ptf; + + HB = HLow; + to_visit0 = to_visit; + loop: + while (pt0 < pt0_end) { + register CELL d0; + register CELL *ptd0; + ++ pt0; + ptd0 = pt0; + d0 = *ptd0; + deref_head(d0, restore_rationals_unk); + restore_rationals_nvar: + { + if (IsPairTerm(d0)) { + CELL *ap2 = RepPair(d0); + if (ap2 >= HB && ap2 < H) { + /* If this is newer than the current term, just reuse */ + *ptf++ = d0; + continue; + } + *ptf = AbsPair(H); + ptf++; +#ifdef RATIONAL_TREES + if (to_visit+1 >= (struct restore_frame *)AuxSp) { + goto heap_overflow; + } + to_visit->start_cp = pt0; + to_visit->end_cp = pt0_end; + to_visit->to = ptf; + to_visit->oldv = *pt0; + to_visit->ground = ground; + to_visit->parent = parent; + to_visit->term_type = pair; + parent = ptf; + /* fool the system into thinking we had a variable there */ + *pt0 = TermFoundVar; + to_visit ++; +#else + if (pt0 < pt0_end) { + if (to_visit+1 >= (struct restore_frame *)AuxSp) { + goto heap_overflow; + } + to_visit->start_cp = pt0; + to_visit->end_cp = pt0_end; + to_visit->to = ptf; + to_visit->ground = ground; + to_visit ++; + } +#endif + ground = TRUE; + pair = TRUE; + pt0 = ap2 - 1; + pt0_end = ap2 + 1; + ptf = H; + H += 2; + if (H > ASP - 2048) { + goto overflow; + } + } else if (IsApplTerm(d0)) { + register Functor f; + register CELL *ap2; + /* store the terms to visit */ + ap2 = RepAppl(d0); + if (ap2 >= HB && ap2 <= H) { + /* If this is newer than the current term, just reuse */ + *ptf++ = d0; + continue; + } + f = (Functor)(*ap2); + + if (IsExtensionFunctor(f)) { + *ptf++ = d0; /* you can just copy extensions, what about DB?*/ + continue; + } else if (f == FunctorLOOP) { + Int nlevels = IntegerOfTerm(ap2[1])-1; + struct restore_frame *visited = to_visit-nlevels; + CELL *p; + int type_pair; + + if (nlevels) { + p = visited->parent; + type_pair = visited->term_type; + } else { + p = parent; + type_pair = pair; + } + if (type_pair) { + *ptf++ = AbsPair(p); + } else { + *ptf++ = AbsAppl(p-1); + } + ground = FALSE; + continue; + } + *ptf = AbsAppl(H); + ptf++; + /* store the terms to visit */ +#ifdef RATIONAL_TREES + if (to_visit+1 >= (struct restore_frame *)AuxSp) { + goto heap_overflow; + } + to_visit->start_cp = pt0; + to_visit->end_cp = pt0_end; + to_visit->to = ptf; + to_visit->oldv = *pt0; + to_visit->ground = ground; + to_visit->parent = parent; + to_visit->term_type = pair; + parent = ptf; + /* fool the system into thinking we had a variable there */ + *pt0 = TermFoundVar; + to_visit ++; +#else + if (pt0 < pt0_end) { + if (to_visit+1 >= (struct restore_frame *)AuxSp) { + goto heap_overflow; + } + to_visit->start_cp = pt0; + to_visit->end_cp = pt0_end; + to_visit->to = ptf; + to_visit->ground = ground; + to_visit ++; + } +#endif + d0 = ArityOfFunctor(f); + pt0 = ap2; + pt0_end = ap2 + d0; + /* store the functor for the new term */ + H[0] = (CELL)f; + ptf = H+1; + H += 1+d0; + pair = FALSE; + if (H > ASP - 2048) { + goto overflow; + } + } else { + *ptf++ = d0; + } + continue; + } + + derefa_body(d0, ptd0, restore_rationals_unk, restore_rationals_nvar); + /* we have already found this cell */ + *ptf++ = (CELL) ptd0; + } + /* Do we still have compound terms to visit */ + if (to_visit > to_visit0) { + to_visit --; + if (ground) { + CELL old = to_visit->oldv; + CELL *newp = to_visit->to-1; + CELL new = *newp; + + *newp = old; + if (IsApplTerm(new)) + H = RepAppl(new); + else + H = RepPair(new); + } + pt0 = to_visit->start_cp; + pt0_end = to_visit->end_cp; + ptf = to_visit->to; +#ifdef RATIONAL_TREES + parent = to_visit->parent; + pair = to_visit->term_type; + *pt0 = to_visit->oldv; +#endif + ground = (ground && to_visit->ground); + goto loop; + } + + /* restore our nice, friendly, term to its original state */ + clean_dirty_tr(TR0); + HB = HB0; + return ground; + + overflow: + /* oops, we're in trouble */ + H = HLow; + /* we've done it */ + /* restore our nice, friendly, term to its original state */ + HB = HB0; +#ifdef RATIONAL_TREES + while (to_visit > to_visit0) { + to_visit --; + pt0 = to_visit->start_cp; + pt0_end = to_visit->end_cp; + ptf = to_visit->to; + parent = to_visit->parent; + pair = to_visit->term_type; + *pt0 = to_visit->oldv; + } +#endif + reset_trail(TR0); + /* follow chain of multi-assigned variables */ + return -1; + + heap_overflow: + /* oops, we're in trouble */ + H = HLow; + /* we've done it */ + /* restore our nice, friendly, term to its original state */ + HB = HB0; +#ifdef RATIONAL_TREES + while (to_visit > to_visit0) { + to_visit --; + pt0 = to_visit->start_cp; + pt0_end = to_visit->end_cp; + ptf = to_visit->to; + parent = to_visit->parent; + pair = to_visit->term_type; + *pt0 = to_visit->oldv; + } +#endif + reset_trail(TR0); + Yap_Error_Size = (ADDR)AuxSp-(ADDR)to_visit0; + return -3; +} + + +static Term +RestoreRational(Term inp, UInt arity) { + Term t = Deref(inp); + tr_fr_ptr TR0 = TR; + + if (IsVarTerm(t)) { + return t; + } else if (IsPrimitiveTerm(t)) { + return t; + } else if (IsPairTerm(t)) { + Term tf; + CELL *ap; + CELL *Hi; + + restart_list: + ap = RepPair(t); + Hi = H; + tf = AbsPair(H); + H += 2; + { + int res; + if ((res = restore_rationals_complex_term(ap-1, ap+1, Hi, Hi, TRUE)) < 0) { + H = Hi; + if ((t = handle_cp_overflow(res, TR0, arity, t))== 0L) + return FALSE; + goto restart_list; + } else if (res) { + H = Hi; + return t; + } + } + return tf; + } else { + Functor f = FunctorOfTerm(t); + Term tf; + CELL *HB0; + CELL *ap; + + restart_appl: + f = FunctorOfTerm(t); + HB0 = H; + ap = RepAppl(t); + tf = AbsAppl(H); + H[0] = (CELL)f; + H += 1+ArityOfFunctor(f); + if (H > ASP-128) { + H = HB0; + if ((t = handle_cp_overflow(-1, TR0, arity, t))== 0L) + return FALSE; + goto restart_appl; + } else { + int res; + + if ((res = restore_rationals_complex_term(ap, ap+ArityOfFunctor(f), HB0+1, HB0, FALSE)) < 0) { + H = HB0; + if ((t = handle_cp_overflow(res, TR0, arity, t))== 0L) + return FALSE; + goto restart_appl; + } else if (res && FunctorOfTerm(t) != FunctorMutable) { + H = HB0; + return t; + } + } + return tf; + } +} + +static Int +p_restore_rational(void) +{ + return Yap_unify(ARG2, RestoreRational(ARG1, 2)); +} + + /* FAST EXPORT ROUTINE. Export a Prolog term to something like: @@ -3649,6 +4269,8 @@ void Yap_InitUtilCPreds(void) Yap_InitCPred("term_variables", 3, p_term_variables3, 0); Yap_InitCPred("term_attvars", 2, p_term_attvars, 0); Yap_InitCPred("is_list", 1, p_is_list, SafePredFlag); + Yap_InitCPred("rational_term_to_tree", 2, p_break_rational, 0); + Yap_InitCPred("tree_to_rational_term", 2, p_restore_rational, 0); Yap_InitCPred("=@=", 2, p_variant, 0); #ifdef DEBUG_IMPORT Yap_InitCPred("import_term", 1, p_import_term, 0); diff --git a/H/TermExt.h b/H/TermExt.h index be71484fa..ed41f464d 100644 --- a/H/TermExt.h +++ b/H/TermExt.h @@ -90,7 +90,6 @@ BlobOfFunctor (Functor f) } typedef struct cp_frame { - CELL *original_cp; CELL *start_cp; CELL *end_cp; CELL *to; diff --git a/H/iatoms.h b/H/iatoms.h index 2e628a768..620af5390 100644 --- a/H/iatoms.h +++ b/H/iatoms.h @@ -145,6 +145,7 @@ AtomKey = Yap_LookupAtom("key"); AtomLDLibraryPath = Yap_LookupAtom("LD_LIBRARY_PATH"); AtomLONGINT = Yap_LookupAtom("LongInt"); + AtomLOOP = Yap_LookupAtom("_LOOP_"); AtomLT = Yap_LookupAtom("<"); AtomLastExecuteWithin = Yap_FullLookupAtom("$last_execute_within"); AtomLeash = Yap_FullLookupAtom("$leash"); @@ -381,6 +382,7 @@ FunctorIs = Yap_MkFunctor(AtomIs,2); FunctorLastExecuteWithin = Yap_MkFunctor(AtomLastExecuteWithin,1); FunctorList = Yap_MkFunctor(AtomDot,2); + FunctorLOOP = Yap_MkFunctor(AtomLOOP,1); FunctorMegaClause = Yap_MkFunctor(AtomMegaClause,2); FunctorMetaCall = Yap_MkFunctor(AtomMetaCall,4); FunctorMinus = Yap_MkFunctor(AtomMinus,2); diff --git a/H/ratoms.h b/H/ratoms.h index be8c91c3b..dc609e0a9 100644 --- a/H/ratoms.h +++ b/H/ratoms.h @@ -145,6 +145,7 @@ AtomKey = AtomAdjust(AtomKey); AtomLDLibraryPath = AtomAdjust(AtomLDLibraryPath); AtomLONGINT = AtomAdjust(AtomLONGINT); + AtomLOOP = AtomAdjust(AtomLOOP); AtomLT = AtomAdjust(AtomLT); AtomLastExecuteWithin = AtomAdjust(AtomLastExecuteWithin); AtomLeash = AtomAdjust(AtomLeash); @@ -381,6 +382,7 @@ FunctorIs = FuncAdjust(FunctorIs); FunctorLastExecuteWithin = FuncAdjust(FunctorLastExecuteWithin); FunctorList = FuncAdjust(FunctorList); + FunctorLOOP = FuncAdjust(FunctorLOOP); FunctorMegaClause = FuncAdjust(FunctorMegaClause); FunctorMetaCall = FuncAdjust(FunctorMetaCall); FunctorMinus = FuncAdjust(FunctorMinus); diff --git a/H/tatoms.h b/H/tatoms.h index 8a272004a..0ac10a304 100644 --- a/H/tatoms.h +++ b/H/tatoms.h @@ -288,6 +288,8 @@ #define AtomLDLibraryPath Yap_heap_regs->AtomLDLibraryPath_ Atom AtomLONGINT_; #define AtomLONGINT Yap_heap_regs->AtomLONGINT_ + Atom AtomLOOP_; +#define AtomLOOP Yap_heap_regs->AtomLOOP_ Atom AtomLT_; #define AtomLT Yap_heap_regs->AtomLT_ Atom AtomLastExecuteWithin_; @@ -760,6 +762,8 @@ #define FunctorLastExecuteWithin Yap_heap_regs->FunctorLastExecuteWithin_ Functor FunctorList_; #define FunctorList Yap_heap_regs->FunctorList_ + Functor FunctorLOOP_; +#define FunctorLOOP Yap_heap_regs->FunctorLOOP_ Functor FunctorMegaClause_; #define FunctorMegaClause Yap_heap_regs->FunctorMegaClause_ Functor FunctorMetaCall_; diff --git a/docs/yap.tex b/docs/yap.tex index c8d2e85a5..83d7dbd86 100644 --- a/docs/yap.tex +++ b/docs/yap.tex @@ -3377,6 +3377,24 @@ 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 rational_term_to_tree(?@var{TI},-@var{TF}) +@findex rational_term_to_tree/2 +@syindex rational_term_to_term/2 +@cnindex rational_term_to_tree/2 +The term @var{TF} is a tree representation (without cycles) for the + Prolog term @var{TI}. Loops are replaced by terms of the form + @code{_LOOP_(@var{LevelsAbove})} where @var{LevelsAbove} is the size of + the loop. + +@item tree_to_rational_term(?@var{TI},-@var{TF}) +@findex tree_to_rational_term/2 +@syindex tree_to_rational_term/2 +@cnindex tree_to_rational_term/2 +Inverse of above. The term @var{TI} is a tree representation (without + cycles) for the Prolog term @var{TF}. Loops replace terms of the form + @code{_LOOP_(@var{LevelsAbove})} where @var{LevelsAbove} is the size of + the loop. + @end table diff --git a/misc/ATOMS b/misc/ATOMS index d3c3676e7..0a6a26df0 100644 --- a/misc/ATOMS +++ b/misc/ATOMS @@ -150,6 +150,7 @@ A Is N "is" A Key N "key" A LDLibraryPath N "LD_LIBRARY_PATH" A LONGINT N "LongInt" +A LOOP N "_LOOP_" A LT N "<" A LastExecuteWithin F "$last_execute_within" A Leash F "$leash" @@ -386,6 +387,7 @@ F Id Id 1 F Is Is 2 F LastExecuteWithin LastExecuteWithin 1 F List Dot 2 +F LOOP LOOP 1 F MegaClause MegaClause 2 F MetaCall MetaCall 4 F Minus Minus 2