yap-6.3/BEAM/eam_split.c

/*************************************************************************
*									 *
*	       BEAM -> Basic Extended Andorra Model                      *
*         BEAM extends the YAP Prolog system to support the EAM          *
*									 *
* Copyright: Ricardo Lopes and NCC - University of Porto, Portugal       *
*									 *
**************************************************************************
* comments:	split related functions                                  *
*************************************************************************/

void do_forking_andbox(struct AND_BOX *a);
Cell copy_structures(Cell c);
void replicate_local_variables(struct AND_BOX *a);
struct OR_BOX *copy_orbox(struct OR_BOX *o,struct AND_BOX *parent,struct status_and *nr_call);
struct AND_BOX *copy_andbox(struct AND_BOX *a,struct OR_BOX *parent);


void do_forking_andbox(struct AND_BOX *a)
{
struct OR_BOX *op,*opp, *new_orbox;
struct AND_BOX *ap, *new_andbox;
int nr_all_alternatives, nr_all_calls;
struct status_and *nr_call,*new_call;
struct status_or *nr_alternative, *alternatives, *new_alternatives;

  beam_nr_call_forking++;
  op=a->parent;     /* or box parent */
  ap=op->parent;    /* and box parent */
  opp=ap->parent;   /* or box parent parent */
  if (opp==NULL) {
    abort_eam("Forking with orbox parent parent NULL, maybe I'm on top ?????");
  }

  alternatives=opp->alternatives;
  nr_all_alternatives=opp->nr_all_alternatives;
  nr_alternative=ap->nr_alternative;
  nr_all_calls=ap->nr_all_calls;
  nr_call=op->nr_call;

  new_andbox=(struct AND_BOX *) request_memory(ANDBOX_SIZE); 
  new_orbox=(struct OR_BOX *) request_memory(ORBOX_SIZE);
  new_andbox->parent=opp;
  //  new_andbox->nr_alternative=nr_alternative;    /* seted after creating a new status_or */
  new_andbox->nr_all_calls=nr_all_calls;
  new_andbox->level=ap->level;
  new_andbox->perms=ap->perms;
  new_andbox->suspended=NULL;
  if (ap->suspended) new_andbox->suspended=addto_suspensions_list(new_andbox,ap->suspended->reason);
  new_andbox->side_effects=ap->side_effects;
 
  if (ap->externals) {
    struct EXTERNAL_VAR *old_externals, *list=NULL;
    old_externals=ap->externals;
    while (old_externals) {
      struct EXTERNAL_VAR *e;
      struct SUSPENSIONS_VAR *s;
      
      e=(struct  EXTERNAL_VAR *) request_memory(EXTERNAL_VAR_SIZE);
      e->value=old_externals->value;
      e->var=(struct PERM_VAR *) old_externals->var;
      e->next=list;
      list=e;

      if (isvar(e->var)) {
        s=(struct SUSPENSIONS_VAR *) request_memory(SUSPENSIONS_VAR_SIZE); /* Add and_box to suspension list of var*/
        s->and_box=new_andbox;
        s->next=e->var->suspensions;
        e->var->suspensions=s;
      }

      old_externals=old_externals->next;
    }
    new_andbox->externals=list;
  } else new_andbox->externals=NULL; 

  new_call=(struct status_and *) request_memory(STATUS_AND_SIZE);
  new_call->call=new_orbox;
  new_call->locals=nr_call->locals;
  new_call->code=nr_call->code;
  new_call->state=WAKE;
  nr_call->state=WAKE;     /* NEW PARA TORNAR A CALL NUM WAKE STATE   */

  new_orbox->parent=new_andbox;
  new_orbox->nr_call=new_call;
  new_orbox->nr_all_alternatives=1;
  new_alternatives=a->nr_alternative;
  new_orbox->alternatives=new_alternatives;

  /* remove  andbox from op */
  op->nr_all_alternatives-=1;
  if (new_alternatives->previous==NULL) op->alternatives=new_alternatives->next; 
  else new_alternatives->previous->next=new_alternatives->next;
  if (new_alternatives->next!=NULL) new_alternatives->next->previous=new_alternatives->previous;
  new_alternatives->next=NULL;
  new_alternatives->previous=NULL;

  a->parent=new_orbox;

  /* increase the nr_alternatives by 1 in opp or_box parent parent and conect new_andbox*/
  new_alternatives=(struct status_or *) request_memory(STATUS_OR_SIZE);
  new_andbox->nr_alternative=new_alternatives;   
  
  new_alternatives->next=nr_alternative;
  new_alternatives->previous=nr_alternative->previous;
  if (nr_alternative->previous==NULL) opp->alternatives=new_alternatives;
  else nr_alternative->previous->next=new_alternatives;
  nr_alternative->previous=new_alternatives;

  new_alternatives->args=nr_alternative->args;
  new_alternatives->code=nr_alternative->code;
  new_alternatives->state=nr_alternative->state;
  new_alternatives->alternative=new_andbox;

  opp->nr_all_alternatives=nr_all_alternatives+1;

  /* copy and_box ap to new_and-box  */
  { struct status_and *first=NULL, *last=NULL,*calls,*calls_new;
     calls=ap->calls;
     while(calls!=NULL) {
       if (calls==nr_call) {
	 calls_new=new_call;
       } else {
        calls_new=(struct status_and *) request_memory(STATUS_AND_SIZE);
	calls_new->code=calls->code;
	calls_new->locals=calls->locals;
	calls_new->state=calls->state;
	calls_new->call=copy_orbox(calls->call,new_andbox,calls_new);  /* Do a exact copy of the tree*/

       }
       if (first==NULL) first=calls_new;
       else  last->next=calls_new; 
       calls_new->previous=last;
       calls_new->next=NULL;
       last=calls_new;
       calls=calls->next;
     }
     new_andbox->calls=first;

  }

   
  /* remove and_box a from suspension list on vars */
  if (a->externals) {
    struct EXTERNAL_VAR *e;
    e=a->externals;
    while(e) {
      if (e->var->home->level>=a->parent->parent->level)
         remove_from_perm_var_suspensions(e->var,a);    
      e=e->next;
    }
  }

  /* Now we have to create new local vars and refresh the external vars to point to those */

  if (beam_MemGoing==1) { 
         beam_VAR_TRAIL=((Cell *) beam_START_ADDR_BOXES)-1;
  } else beam_VAR_TRAIL=(Cell *) beam_START_ADDR_HEAP;
  beam_VAR_TRAIL_NR=0;
  replicate_local_variables(new_andbox);
}


struct OR_BOX *copy_orbox(struct OR_BOX *o,struct AND_BOX *parent,struct status_and *nr_call)
{
struct OR_BOX *new_orbox;
struct status_or *old,*new,*first=NULL,*last=NULL;

   if (o==NULL) return(NULL);
   
   new_orbox=(struct OR_BOX *) request_memory(ORBOX_SIZE);
   new_orbox->parent=parent;
   new_orbox->nr_call=nr_call;
   new_orbox->nr_all_alternatives=o->nr_all_alternatives;
   old=o->alternatives;
   while(old!=NULL) {
     new=(struct status_or *) request_memory(STATUS_OR_SIZE);
     new->args=old->args;
     new->code=old->code;
     new->state=old->state;
     new->alternative=copy_andbox(old->alternative,new_orbox);
     if (new->alternative!=NULL) new->alternative->nr_alternative=new;

     if (first==NULL) first=new;
     else last->next=new;
     new->previous=last;
     new->next=NULL;
     last=new;			
     old=old->next;
   }
   new_orbox->alternatives=first;

return(new_orbox);
}

struct AND_BOX *copy_andbox(struct AND_BOX *a,struct OR_BOX *parent)
{
struct AND_BOX *new_andbox;

  if (a==NULL) return(NULL);

  new_andbox=(struct AND_BOX *) request_memory(ANDBOX_SIZE); 
  new_andbox->parent=parent;
  //  new_andbox->nr_alternative=a->nr_alternative;  /* this is seted in the copy_orbox, after calling copy_andbox */
  new_andbox->nr_all_calls=a->nr_all_calls;
  new_andbox->level=a->level;
  new_andbox->perms=a->perms;
  new_andbox->externals=a->externals;
  new_andbox->side_effects=a->side_effects;
  new_andbox->suspended=NULL;
  if (a->suspended) {
     new_andbox->suspended=addto_suspensions_list(new_andbox,a->suspended->reason);
  }

  { struct status_and *first=NULL, *last=NULL,*calls,*calls_new;
     calls=a->calls;
     while(calls!=NULL) {
        calls_new=(struct status_and *) request_memory(STATUS_AND_SIZE);
	calls_new->code=calls->code;
	calls_new->locals=calls->locals;
	calls_new->state=calls->state;
	calls_new->call=copy_orbox(calls->call,new_andbox,calls_new);  /* Do a exact copy of the tree*/

        if (first==NULL) first=calls_new;
        else  last->next=calls_new;
        calls_new->previous=last;
	calls_new->next=NULL;
        last=calls_new;
        calls=calls->next;
     }
     new_andbox->calls=first;
  }

return(new_andbox);
}


void replicate_local_variables(struct AND_BOX *a) /* used by fork -ABX is set*/
{
struct PERM_VAR *l,*new_list;
int i,OLD_VAR_TRAIL_NR;
struct EXTERNAL_VAR *old_externals,*externals;

if (a==NULL) return;

  OLD_VAR_TRAIL_NR=beam_VAR_TRAIL_NR; 
  l=a->perms;
  new_list=NULL;
  while(l) {
        struct PERM_VAR *new;
        Cell *c;
    
        new=request_permVar(a);
	new->yapvar=l->yapvar;
	new->next=new_list;
	new_list=new;

        c=&l->value;
        beam_VAR_TRAIL[beam_VAR_TRAIL_NR]=(Cell) c;
	beam_VAR_TRAIL_NR-=beam_MemGoing;
        beam_VAR_TRAIL[beam_VAR_TRAIL_NR]=(Cell) *c;
	beam_VAR_TRAIL_NR-=beam_MemGoing;

        if ((Cell *)*c==c) {
	     new->value=(Cell) &new->value;
	     *c=new->value;
	} else {
	     new->value= (Cell) *c;
	     *c=(Cell) &new->value;
	}
        l=l->next;
  }
  a->perms=new_list;
  l=new_list;
  while(l) {
	l->value=copy_structures(l->value);
        l=l->next;
  }

  /* At this point all old local vars are pointing to the new local vars */

  if (a==beam_ABX) {   /* Nao preciso de criar um novo vector das externals */
    old_externals=a->externals;
    while(old_externals) {
      if (old_externals->var->home->level>=beam_ABX->parent->parent->level) {
	  old_externals->value=copy_structures((Cell ) old_externals->value);
	  old_externals->var=(struct PERM_VAR *) old_externals->var->value;
          if (isvar(old_externals->var)) {
	    struct SUSPENSIONS_VAR *s;
	    s=(struct SUSPENSIONS_VAR *) request_memory(SUSPENSIONS_VAR_SIZE); /* Add and_box to suspension list of var*/
	    s->and_box=a;
	    s->next=old_externals->var->suspensions;
	    old_externals->var->suspensions=s;
	  }
      }
      old_externals=old_externals->next;
    }
 } else {

  old_externals=a->externals;
  externals=NULL;
  a->externals=NULL;

  while(old_externals) {
      struct EXTERNAL_VAR *e;
      struct SUSPENSIONS_VAR *s;

      e=(struct  EXTERNAL_VAR *) request_memory(EXTERNAL_VAR_SIZE);
      e->next=externals;
      externals=e;

      if (old_externals->var->home->level>=beam_ABX->parent->parent->level) {
	e->value=copy_structures((Cell ) old_externals->value);
	e->var=(struct PERM_VAR *) old_externals->var->value;
      } else {
	e->value=old_externals->value;
	e->var=(struct PERM_VAR *) old_externals->var->value;
      }
      
      if (isvar(e->var)) {
	s=(struct SUSPENSIONS_VAR *) request_memory(SUSPENSIONS_VAR_SIZE); /* Add and_box to suspension list of var*/
	s->and_box=a;
	s->next=e->var->suspensions;
	e->var->suspensions=s;
      }

      old_externals=old_externals->next;
   }
   a->externals=externals;
 }


 /* CUIDADO: Preciso agora de duplicar os vectores das variaveis locais */     
  { struct status_and *calls;
#if !Fast_go
    Cell **backup=NULL; int i, counted=0,max=1000;
    backup=(Cell **) malloc(max);
#else
    Cell *backup[1000]; int i, counted=0;
#endif
   
   calls=a->calls;
   while(calls!=NULL) {
        if (calls->locals!=NULL) {
	  /* primeiro vou ver se j<> foi copiado */
	  for(i=0;i<counted;i+=2) {
	    if (backup[i]==calls->locals) {
	      calls->locals=backup[i+1];
	      break;
	    }
	  }
	  if (i==counted) { /* afinal ainda nao foi copiado: fazer copia em duas fases*/
	    Cell *c, *newvars, *oldvars; int nr;

	    oldvars=calls->locals;
	    nr=oldvars[-1];
       	    newvars=request_memory_locals_noinit(nr);
	    calls->locals=newvars;
	    /* primeiro actualizo as variaveis */
	    for(i=0;i<nr;i++) {
	      c=&oldvars[i];
              beam_VAR_TRAIL[beam_VAR_TRAIL_NR]=(Cell) c;
 	      beam_VAR_TRAIL_NR-=beam_MemGoing;
              beam_VAR_TRAIL[beam_VAR_TRAIL_NR]=(Cell) *c;
	      beam_VAR_TRAIL_NR-=beam_MemGoing;	    

              if ((Cell *)*c==c) {
	        newvars[i]=(Cell) &newvars[i];
	        *c=newvars[i];
  	      } else {
		newvars[i]= (Cell) *c;
	        *c=(Cell) &newvars[i];
	      }	      
	    }
	    /* depois copio as estruturas */
	    for(i=0;i<nr;i++) {
	      newvars[i]=copy_structures(oldvars[i]);
	    }
#if !Fast_go
	    if (max<counted+2) { 
	       max+=200;  
	       backup=realloc(backup,max); 
	       if (backup==NULL) abort_eam("No more memory... realloc in gc \n");
	    } 
#else
	    if (counted>=998) abort_eam("No more memory... realloc in gc \n");
#endif
	    backup[counted]=oldvars;
	    backup[counted+1]=newvars;
	    counted+=2;
	  }
        }
	calls=calls->next;
   }
#if !Fast_go
   free(backup);
#endif
  }

  /* redo the process to the inner boxes */
  { struct status_and *calls;

   calls=a->calls;
   while(calls!=NULL) {
     
    if (calls->call!=NULL) {
      register struct OR_BOX *o;
      register struct status_or *nr;

      o=calls->call;
      nr=o->alternatives;
      while(nr!=NULL) {
	replicate_local_variables(nr->alternative); 
	nr=nr->next;
      }
    }
    calls=calls->next;
   }
  }

  if (beam_MemGoing==1) {
     for(i=OLD_VAR_TRAIL_NR;i>beam_VAR_TRAIL_NR;i-=2) {
        Cell *c;
        c=(Cell *) beam_VAR_TRAIL[i];
        *c=(Cell) beam_VAR_TRAIL[i-1];
     }
  } else {
     for(i=OLD_VAR_TRAIL_NR;i<beam_VAR_TRAIL_NR;i+=2) {
        Cell *c;
        c=(Cell *) beam_VAR_TRAIL[i];
        *c=(Cell) beam_VAR_TRAIL[i+1];
     }
  }

  beam_VAR_TRAIL_NR=OLD_VAR_TRAIL_NR;
}



Cell copy_structures(Cell c) 
{
Cell *NewC, *NewH;
Cell OldC,OldH;

  OldC=deref((Cell) c);

  if (isvar(OldC)) {
    return(OldC);
  }
  if (isatom(OldC)) { 
    return(OldC);
  }

  OldH=(Cell) beam_H;
  NewH=beam_H;
  if (isappl(OldC)) {
    int i,arity;

    NewC=(Cell *) repappl(OldC);
    arity = ((int) ArityOfFunctor((Functor) *NewC));
    *NewH++=*NewC++;
    beam_H+=arity+1;
    for(i=0;i<arity ;i++) {
       *NewH=copy_structures((Cell) NewC);
       NewH++;
       NewC++;
    }
    return(absappl(OldH));
  } 
  /* else if (ispair(c)) { */
     NewC=(Cell *) reppair(OldC);
     beam_H+=2;
     *NewH=copy_structures((Cell) NewC);
     NewC++; 
     NewH++;
     *NewH=copy_structures((Cell) NewC);
     return(abspair(OldH));
}