/* ---------------------------------------------------------- % (C)1992 Institute for New Generation Computer Technology % (Read COPYRIGHT for detailed information.) ----------------------------------------------------------- */ /*===================================================================== * cu-Prolog III (Constraint Unification Prolog) * Copyright: Institute for New Generation Computer Technology,Japan * 1989--91 ==================================================================== */ /*-------------------------------------------------------------------- * <<<< new.c >>>> * memory management * 93.8.2 speedup * 94.6.28 speedup --------------------------------------------------------------------*/ #define DEBUG 0 /* if Debug 1 else 0 */ #define NEW 1 #include "include.h" #include /* struct allocation macro int a:arity */ int TERM_SIZE = (sizeof(struct term) / sizeof(int)); int FUNC_SIZE = (sizeof(struct func) / sizeof(int)); int POINTER_SIZE = (sizeof(struct term *) / sizeof(int)); #if SUN4 == 1 #define Termalloc(a) (struct term *)salloc(TERM_SIZE + a * POINTER_SIZE) #define tempterm(a) (struct term *)alloc(TERM_SIZE + a * POINTER_SIZE) #define mediterm(a) (struct term *)challoc(TERM_SIZE + a * POINTER_SIZE) #define funcalloc(a) (struct func *)salloc(FUNC_SIZE + a * POINTER_SIZE) #else #define Termalloc(a) (struct term *)salloc(TERM_SIZE + (a-1) * POINTER_SIZE) #define tempterm(a) (struct term *)alloc(TERM_SIZE + (a-1) * POINTER_SIZE) #define mediterm(a) (struct term *)challoc(TERM_SIZE + (a-1) * POINTER_SIZE) #define funcalloc(a) (struct func *)salloc(FUNC_SIZE + (a-1) * POINTER_SIZE) #endif void print_hash_table() /* for debug */ { register int i,empty=0,conflict=0; int conflict_max=0,total_length=0; float mean, d; register struct func *f; for (i = 0; i < HASH_SIZE; i++){ printf("[%d]",i); for (f = hash_list[i],conflict=0; f != NULL; f = f->f_link,conflict++) printf("%s/%d ",f->f_name,f->f_arity); putchar('\n'); total_length += conflict; if (conflict == 0) empty++; if (conflict_max < conflict) conflict_max=conflict; } mean = (float)total_length/(float)HASH_SIZE; for (i =d=0; i < HASH_SIZE; i++) { for (f = hash_list[i],conflict=0; f != NULL; f = f->f_link,conflict++) d+= (float)(conflict - mean)*(float)(conflict - mean)/HASH_SIZE; } printf("empty = %d/%d (%.2f), longest = %d, total=%d,\naverage_length=%.2f, d=%.3f\n", empty, HASH_SIZE, ((float)empty/(float)HASH_SIZE), conflict_max, total_length, ((float)total_length/(float)(HASH_SIZE-empty)), sqrt(d)); } int hash(fname) char *fname; { register int h = 0, factor; /* for (factor = strlen(fname) + 1; *fname != '\0'; fname++, factor--) */ /* for (factor = 1; *fname != '\0'; fname++, factor++) h+= ((*fname) * factor); */ for (; *fname != '\0'; fname++) h+= (unsigned char)(*fname); /* for EUC Kanji 94.10.27 */ if (h < 0) return(0); else return(h % HASH_SIZE); } int *salloc(n) /* system heap allocation */ register int n; { register int *p; #if DEBUG == 1 if (shp < SHEAPBOTTOM) error("system heap underflow"); #endif p = shp; shp += n; if (shp < SHEAPTOP) return(p); else error("system heap overflow"); } int *alloc(n) /* user heap allocation */ register int n; { register int *p; /* - hp */ p = hp; hp += n; #if DEBUG == 1 if (hp < HEAPBOTTOM){ sprintf(nbuf,"hp = %d : user heap underflow",hp); error(nbuf); } #endif if (hp < HEAPTOP) return(p); else error("user heap overflow"); } int *challoc(n) /* constraints/pst heap allocation */ register int n; { register int *p; p = chp; chp += n; #if DEBUG == 1 if (chp < CHEAPBOTTOM){ sprintf(nbuf,"chp = %d : constraints heap underflow",chp); error(nbuf); } #endif if (chp < CHEAPTOP) return(p); else error("constraints heap overflow"); } struct pair *ealloc(n) /* envionment stack allocation */ register int n; { register struct pair *p; p = ep; ep += n; #if DEBUG == 1 if (ep < eheap){ sprintf(nbuf,"ep = %d : environment stack underflow",ep); error(nbuf); } #endif if (ep < ESPTOP) return(p); else error("environment stack overflow"); } char *nalloc(n,flag) /* name string heap allocation */ register char *n; int flag; { register char *p; register int q; register struct func *f; if ((&nheap[0] <= n) && (n <= nhp)) return(n); if ((f = exist_fname(n)) != NULL) return(f->f_name); /* - nhp */ switch (flag) { case ETERNAL: case MEDIUM: q = strlen(n)+1; p = nhp; nhp += q; if(nhp > NHEAPTOP) error("name heap overflow"); break; default : /* TEMPORAL or STINGY */ q = strlen(n)+4; p = (char *)alloc(q / sizeof(int)); } strcpy(p,n); return(p); } struct term *Nnum(nbuf,flag) /* make number */ char *nbuf; int flag; { register struct term *n; float x; double atof(); MEMORY_ALLOC(n,term,flag); n->type.ident = ATOMIC_TYPE; sscanf(nbuf,"%f",&x); n->tag.n_value = x; if (x == ((float)((int)x))) n->t_arity = INT_NUM; else n->t_arity = FLOAT_NUM; return(n); } struct term *Nnum_val(x,flag) /* make a term representing x */ register float x; int flag; { register struct term *n; MEMORY_ALLOC(n,term,flag); n->type.ident = ATOMIC_TYPE; if (x == ((float)((int)x))) n->t_arity = INT_NUM; else n->t_arity = FLOAT_NUM; n->tag.n_value = x; return(n); } struct term *Nstr(x, flag) /* make a term representing x */ char *x; int flag; { register struct term *s; MEMORY_ALLOC(s,term,flag); s->type.ident = ATOMIC_TYPE; s->t_arity = STRING; if (flag==STINGY) flag=ETERNAL; s->tag.s_value = nalloc(x,flag); return(s); } struct pst *Npst(flag) int flag; { register struct pst *p; struct pstvar *pv; MEMORY_ALLOC(p,pst,flag); p->type = PST_TYPE; MEMORY_ALLOC(pv,pstvar,flag); pv->v_type = VAR_PST_TYPE; pv->v_name = vname(Anonymous_var); pv->v_number = p_number++; pv->v_link = pv_list; pv->old_var = NULL; p->p_var = pv_list = (struct term *)pv; p->p_lists = NULL_ECL; return(p); } struct eclause *Neclause(val,env,tail,flag) struct term *val; struct pair *env; struct eclause *tail; int flag; { struct eclause *obj; MEMORY_ALLOC(obj,eclause,flag); obj->c_type = ECLAUSE_TYPE; obj->c_env = env; obj->c_form = val; obj->c_link = tail; return(obj); } struct term *Npst_item(p,pobj,next) struct pair *p; struct eclause *pobj; struct pst_item *next; { struct pst_item *t; t = cnew(pst_item); t->p_var = p; t->p_lists = pobj; t->p_link = next; return((struct term *)t); } /* psttable (temporal PST area) functions */ /* initialize_psttable() clear_psttable() find_pstitem() remove_pstitem() remove_pstitem_if_not_equal() record_pstobjects() record_pstlists() */ int psttable_size() { int i; struct pst_item *pi; for (pi = psttable,i=0; pi != NULL; pi=pi->p_link,i++) ; return(i); } void initialize_psttable() { psttable = snew(pst_item); } void clear_psttable() { psttable->p_link = NULL_PSTIT; } struct pst_item *find_pstitem(t,e) struct term *t; struct pair *e; { register struct pair *p; register struct pst_item *table = psttable->p_link; if (e==NULL_ENV) return(NULL_PSTIT); t = ((struct pst *)t)->p_var; down(p,t,e); while (table != NULL_PSTIT) { if (table->p_var <= p) { if (table->p_var == p) return(table); else return(NULL_PSTIT); } table = table->p_link; } return(table); } /* remove (t,e) from psttable if it is not equal pitem */ struct pst_item *remove_pstitem_if_not_equal(t,e,pitem) struct term *t; struct pair *e; struct pst_item *pitem; { struct pst_item *object, *target; struct pair *p; if (e==NULL_ENV) /* 94.5.20 H.Tsuda*/ return(NULL_PSTIT); t = ((struct pst *)t)->p_var; down(p,t,e); target = psttable; while ((object = target->p_link) != NULL_PSTIT) { if (object->p_var <= p) { if (object->p_var == p) { if (object == pitem) return(pitem); /* doesn't remove */ upush(&(target->p_link)); target->p_link = object->p_link; return(object); } else return(NULL_PSTIT); } target = object; } return(object); } struct pst_item *remove_pstitem(t,e) /* remove (t,e) from psttable */ struct term *t; struct pair *e; { return( remove_pstitem_if_not_equal(t,e, NULL_PSTIT) ); } struct pst_item *record_pstobjects(t,e) struct pst *t; struct pair *e; { struct pst_item *entry = psttable; struct term *tt = t->p_var; struct pair *p; down(p,tt,e); while(entry->p_link != NULL_PSTIT) { if (p > entry->p_link->p_var) break; entry = entry->p_link; } upush(&(entry->p_link)); entry->p_link = (struct pst_item *) Npst_item(p,NULL_ECL,entry->p_link); entry = entry->p_link; entry->p_lists = record_pstlists(t->p_lists,e); /* printf("PSTtable size = %d\n",psttable_size()); */ return(entry); } struct eclause *record_pstlists(ptt,e) struct eclause *ptt; struct pair *e; { struct eclause *props, *pre; if (ptt == NULL_ECL) return(ptt); pre = props = Npstobj(ptt->c_form, e, NULL_ECL, MEDIUM); for (ptt = ptt->c_link; ptt != NULL_ECL; ) { props->c_link = Npstobj(ptt->c_form, e, NULL_ECL, MEDIUM); props = props->c_link; ptt = ptt->c_link; } return(pre); } /* ------------------------- */ struct term *Nfile(x) FILE *x; { register struct term *t; t = cnew(term); t->type.ident = ATOMIC_TYPE; t->t_arity = FILE_POINTER; t->tag.f_value = x; return(t); } struct term *Nvar(nbuf,flag) /* make new var */ char *nbuf; int flag; { register struct var *v; /* + nbuf */ /* - v_number, v_list, shp */ MEMORY_ALLOC(v,var,flag); v->v_type = VAR_GLOBAL_TYPE; v->v_number = v_number++; v->v_name = (nbuf==Anonymous_VarName) ? Anonymous_VarName : nalloc(nbuf,flag); v->v_link = (struct var *)v_list; v_list = (struct term *)v; v->v_constraint = NULL_CL; /* for CAHC 89.6.16 */ v->v_component = (struct component *)NULL; v->v_head_occur = 0; /* var occurrence in the head */ v->v_occurrence = 1; /* var occurrence */ return(v_list); } struct term *varsearch(varname) /* search varname in v_list */ char *varname; { register struct term *v; for (v = v_list; v != NULL; v = vlink(v)) if (streq(varname, vname(v))) { ((struct var *)v)->v_occurrence++; return(v); } return(NULL); } void reset_voccurrence(v) /* all v_occurrence = 0 */ register struct term *v; { while (v != NULL_TERM) { ((struct var *)v)->v_occurrence = 0; v = vlink(v); } } /* move v_occurrence->v_head_occur, v_occurrence=0*/ void move_voccurrence(v) register struct term *v; { while (v != NULL_TERM) { ((struct var *)v)->v_head_occur = ((struct var *)v)->v_occurrence; ((struct var *)v)->v_occurrence = 0; v = vlink(v); } } void recalc_voccur_sub(t) /* subroutine for recacl_voccurrence() */ struct term *t; { if (t == NULL_TERM || isconst(t)) return; switch (t->type.ident) { case VAR_VOID_TYPE: /* var */ case VAR_GLOBAL_TYPE: ((struct var *)t)->v_occurrence++; case VAR_PST_TYPE: case ATOMIC_TYPE: case CONST_LIST_TYPE: return; case PST_TYPE: { register struct eclause *ec; for (ec=(struct eclause *)((struct pst *)t)->p_lists; ec != NULL_ECL; ec=ec->c_link) recalc_voccur_sub(Arg2(ec->c_form)); return; } /* case ECLAUSE_TYPE: register struct eclause *ec; for (ec=(struct eclause *)t; ec != NULL_ECL; ec=ec->c_link) recalc_voccur_sub(Arg2(ec->c_form)); return; */ case CLAUSE_TYPE: case LIST_TYPE: recalc_voccur_sub(head_of_list(t)); recalc_voccur_sub(tail_of_list(t)); return; default: /* complex term */ { register int i, j=Pred(t)->f_arity; for (i = 0; i < j; i++) recalc_voccur_sub(Arg(t,i)); } } } void decrement_vacuous(t) /* decrement voccurrence of vacuous position */ struct term *t; { register struct func *f; register int i; register struct term *arg; if (isvar(t)) return; /* 94.12.2 call(X):-X. */ for (f = Pred(t),i = f->f_arity - 1; i >= 0; i--) { arg = Arg(t,i); if (isvar(arg) && Component(f,i) == NULL) vdecrement(arg); } } void recalc_voccurrence(cl,v) /* cl == H :- C. */ struct clause *cl; struct term *v; { register struct clause *c; if (cl == NULL_CL || v == NULL_TERM) return; reset_voccurrence(v); /* all voccurrence=0 */ recalc_voccur_sub(cl->c_form); /* check head */ move_voccurrence(v); /* body var -> head var */ for (c = cl->c_link; c != NULL; c = c->c_link) /* check body */ recalc_voccur_sub(c->c_form); for (c = cl->c_link; c != NULL; c = c->c_link) /* vacuous vars */ decrement_vacuous(c->c_form); } struct func *exist_fname(fname) /* search predicate name */ char *fname; { register struct func *f; for (f = hash_list[hash(fname)]; f != NULL; f = f->f_link) if (streq(fname,f->f_name)) return(f); return(NULL); } struct func *Predicate(fname, arity) /* search fname/arity */ char *fname; /* if not exist, make Nfunc */ int arity; { register struct func *f; f = funcsearch(fname,arity); if (f == NULL) return(Nfunc(USERFUN,fname,arity)); else return(f); } struct func *funcsearch(fname, arity) /* search fname/arity */ char *fname; int arity; { register struct func *f; register int compare; for (f = hash_list[hash(fname)]; f != NULL; f = f->f_link) { if ((compare = strcmp(fname,f->f_name)) > 0) return(NULL); if ((compare == 0) && (f->f_arity == arity)) return(f); } return(NULL); } int pred_compare(f1,f2) /* pred compare -1 <, 0: =, 1 > */ struct func *f1,*f2; { register int cmp; cmp = strcmp(f1->f_name,f2->f_name); if (cmp != 0) return(cmp); return(f2->f_arity - f1->f_arity); } void index_func(fnew) /* store predicate fnew into hash-table */ struct func *fnew; { struct func *flist; register struct func *f, *flast; int i = hash(fnew->f_name); flist = hash_list[i]; if ((flist == NULL) || (pred_compare(fnew,flist) > 0)) { hash_list[i] = fnew; fnew->f_link = flist; return; } for (flast=flist, f=flist->f_link; f != NULL; flast = f, f = f->f_link) { i = pred_compare(fnew,f); if (i > 0) break; if (i==0) { /* sprintf(nbuf,"function `%s' is already used",fnew->f_name); error(nbuf); */ return; } } flast->f_link = fnew; fnew->f_link = f; return; } struct itrace *index_newflist(fl,it) struct itrace *fl,*it; { register struct itrace *t, *top, *s, *temp; if (fl==it) return(fl); top = temp = new(itrace); for (t=fl; t != it; t=t->it_link) { if (in_sheap(t)) { temp->it_link = t; temp = t; } else { temp->it_link = s = snew(itrace); s->it_anumber = t->it_anumber; s->it_cnumber = t->it_cnumber; temp = s; } temp->it_clause = up_itrace_clause(t->it_clause,t->it_anumber); } temp->it_link=it; return(top->it_link); } struct operator *op_search(fname,otype) char *fname; register int otype; { register struct operator *o; register struct func *f; f = (otype != INFIX) ? funcsearch(fname,1) : funcsearch(fname,2); if (f == NULL) return(NULL); for (o=o_list; o != NULL; o=o->o_link) if ((f == o->o_func) && (otype == (o->o_type & INFIX))) return(o); return(NULL); } struct func *Nfunc(ftype, n, a) /* make new function */ int ftype; /* predicate type in include.h */ char *n; /* functor name */ int a; /* arity */ { register struct func *f, *ff; int i; /* - FNUMBER, const_list,f_list, shp */ f = funcalloc(a); f->f_arity = a; f->f_name = nalloc(n,ETERNAL); f->f_setcount = 0; /* number of def clauses */ f->f_unitcount = 0; /* number of unit clauses */ f->def.f_set = NULL; f->f_number = FNUMBER++; f->f_integ = NULL; if (ftype != TEMPFUN) { f->f_mark = (a > 0) ? (ftype | VACUITY_NOCHECK) : ftype; index_func(f); } else { f->f_mark = (a > 0) ? (USERFUN | VACUITY_NOCHECK) : USERFUN; ff = f_list; f_list = f; f->f_link = ff; } for (i = 0; i < a; i++) Component(f,i)=NULL; return(f); } struct term *Nterm(n,flag) int n; /* arity */ int flag; { struct term *t; /* alloc term in sheap */ /* if (n > VMAX) error("Too many arguments"); */ switch (flag) { case TEMPORAL: t = tempterm(n); break; case ETERNAL: case STINGY: t = Termalloc(n); break; default: /* MEDIUM */ t = mediterm(n); } t->t_arity = n; return(t); } struct pair *Nenv(n) /* new environment for n vars */ register int n; { register struct pair *p; register int i; p = ealloc(n); for(i = 0; i < n; i++) { p[i].p_body = NULL; p[i].p_env = NULL; } return(p); } struct clause *Nlist(head,body,flag) struct term *head; struct clause *body; int flag; { register struct clause *c; MEMORY_ALLOC(c,clause,flag); c->c_type = (novar(head) && ((body == (struct clause *)NIL) || (body->c_type == CONST_LIST_TYPE))) ? CONST_LIST_TYPE : LIST_TYPE; c->c_form = head; c->c_link = body; return(c); } struct clause *Nclause(head,body,flag) struct term *head; struct clause *body; int flag; { register struct clause *c; MEMORY_ALLOC(c,clause,flag); c->c_type = CLAUSE_TYPE; c->c_form = head; c->c_link = body; return(c); } struct set *setconcat(slist, s) /* add s to the end of slist */ struct set *slist,*s; { register struct set *ss; if (slist == NULL) return(s); for(ss = slist; ss->s_link != NULL; ss = ss->s_link) ; ss->s_link = s; return(slist); } int literalnumber(c) /* number of literals in c */ register struct clause *c; { register int i; for (i = 0; c != NULL; c = c->c_link, i++); return(i); } int is_ground(t) /* check whether t is ground. */ struct term *t; { if (t == NULL_TERM || isconst(t)) return(TRUE); switch (t->type.ident) { case VAR_VOID_TYPE: /* var */ case VAR_PST_TYPE: case ATOMIC_TYPE: case CONST_LIST_TYPE: return(TRUE); case VAR_GLOBAL_TYPE: case PST_TYPE: return(FALSE); case CLAUSE_TYPE: case LIST_TYPE: if (is_ground(head_of_list(t)) && is_ground(tail_of_list(t))) return(TRUE); else return(FALSE); default: /* complex term */ { register int i, j=Pred(t)->f_arity; for (i = 0; i < j; i++) if (is_ground(Arg(t,i)) == FALSE) return(FALSE); return(TRUE); } } } void index_set(chead,con,flag) struct clause *chead, *con; char flag; { struct set *s; if (issystem(Pred(chead->c_form))) { sprintf(nbuf,"Caution!! : %s is a system predicate.\n", Pred(chead->c_form)->f_name); error(nbuf); } s = snew(set); s->s_clause = chead; recalc_voccurrence(chead, v_list); s->s_vlist = v_list; s->s_anumber = v_number+p_number; s->s_constraint = con; s->s_link = NULL; s->s_ground_head = is_ground(chead->c_form); /* head is ground? */ add_set(s,flag); } void add_set(s,flag) /* add definition s to the end */ struct set *s; char flag; /* 'a' or 'z' */ { register struct func *f = s->s_clause->c_form->type.t_func; struct set *setconcat(); /* check set_bodynumber */ s->s_bodynumber = literalnumber(s->s_clause->c_link); if (flag == 'z') f->def.f_set = setconcat(f->def.f_set, s); else { s->s_link = f->def.f_set; f->def.f_set = s; } f->f_setcount++; if is_unitclause(s) f->f_unitcount++; /* add_f_cbind(s->s_clause->c_form); *//* calc f_cbind[] */ Def_Modified = 1; /* def modified flag (global v.) */ } /*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ user stack operations: upush(), undo() ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/ void upush(p) register int *p; { /* - usp */ if (p == NULL) return; usp->u_addr = p; (usp++)->u_val = *p; /* for MS-DOS large model *//* #if MSDOS == 2 usp->u_addr = p + 1; (usp++)->u_val = *(p + 1); #endif */ #if DEBUG == 1 if (p < HEAPBOTTOM || p > HEAPTOP) error("out of range in upush"); if (usp < STACKBOTTOM) error("user stack underflow"); #endif if (usp > STACKTOP) error("user stack overflow"); } void undo(u) register struct ustack *u; { /* - usp */ #if DEBUG == 1 if (u < STACKBOTTOM) error("user stack underpop"); #endif /* if (u > usp) error("user stack overpop"); if (usp > Stack_Max) Stack_Max = usp; if (chp > Cheap_Max) Cheap_Max = chp; if (hp > Heap_Max) Heap_Max = hp; if (ep > Esp_Max) Esp_Max = ep; =====> backtrack_node() */ while(usp > u) { --usp; #if DEBUG == 1 if (usp->u_addr < HEAPBOTTOM || usp->u_addr > HEAPTOP) fprintf(stderr, " over heap (undo)%x/%x\n",usp,STACKBOTTOM); #endif if (usp->u_addr == NULL) return; else *(usp->u_addr) = usp->u_val; } }