1 /*************************************************************************
2 * *
3 * BEAM -> Basic Extended Andorra Model *
4 * BEAM extends the YAP Prolog system to support the EAM *
5 * Copyright: Ricardo Lopes and NCC - University of Porto, Portugal *
6 * *
7 **************************************************************************
8 * comments: eam abstract machine emulator *
9 * *
10 * IMPORTANT: ON i386 ISAPPL SHOUD ALWAYS BE AFTER ISVAR *
11 *************************************************************************/
12
13 #ifdef BEAM
14
15 #include "Yap.h"
16 #include "Yatom.h"
17 #include <stdlib.h>
18 #include <stdio.h>
19 #include <string.h>
20 #include <sys/types.h>
21 #include <sys/mman.h>
22 #include <sys/stat.h>
23 #include <fcntl.h>
24 #include <unistd.h>
25
26 #define Debug 0
27 #define Debug_GC 1
28 #define Debug_Dump_State 0 /* 0 =off || 1==only on Scheduling || 2== only on GC || 4=on every abs inst NOTE: DEBUG has to be enable to use 4*/
29 #define Debug_MEMORY 0
30 #define Memory_Stat 0
31 #define Clear_MEMORY 0 /* 0- do not clear || 1-> clear on request || 2-> clear on release || 3 -> both*/
32 #define Fast_go 1 /* normaly 1 ; use 0 to run some extra tests only to control some possible bugs (slower) */
33 #define USE_SPLIT 1
34
35 #define MEM_FOR_BOXES 32 /* In Mb */
36 #define MEM_FOR_HEAP 32 /* In Mb */
37 #define MEM_FOR_VARS 32 /* In Mb */
38 #define MEM_BOXES MEM_FOR_BOXES*1024*1024
39 #define MEM_H MEM_FOR_HEAP*1024*1024
40 #define MEM_VARS MEM_FOR_VARS*1024*1024
41 #define INDEX_SIZE 100000 /* size of vector for saving memory requests */
42
43 #define GARBAGE_COLLECTOR 2 /* 0= NO GC || 1 = Heap only || 2 = Heap + Box */
44 #define HYBRID_BOXMEM 1 /* 0 - Off || 1 - On */
45 #define START_ON_NEXT 1 /* PLEASE DON'T CHANGE , specially if you use skip_while_var */
46 #define USE_LEFTMOST 1 /* SHOULD ALWAYS BE 1 for now... */
47 #define MICRO_TIME 1 /* 0 == eamtime uses CPU time 1 == eamtime uses total time */
48 #define MAX_MEMORYSTAT 5000
49 #define READ 0
50 #define WRITE 1
51
52 #include "eam.h"
53 #include "eamamasm.h"
54
55 int EAM=0; /* Is EAM enabled ? */
56 Cell *beam_ALTERNATIVES; /* NEEDED FOR ABSMI */
57 PredEntry *bpEntry;
58 struct EAM_Global EAMGlobal;
59 struct EAM_Global *eamGlobal=&EAMGlobal;
60
61 #if !Debug
62 #define INLINE inline
63 #define DIRECT_JUMP 1
64 #else
65 #define INLINE
66 #define DIRECT_JUMP 0
break_top(void)67 void break_top(void); void break_top(void) { };
68 void break_debug(int);
break_debug(int conta)69 void break_debug(int conta) {
70 #if Debug_Dump_State & 4
71 dump_eam_state();
72 #endif
73 if (Debug!=-1 && conta>Debug*100) {printf("exit por contador>debug\n"); exit(1); }
74 };
75 #endif
76
77 #define push_mode_and_sreg() { *--beam_sp = (Cell) beam_Mode; *--beam_sp = (Cell) beam_S; }
78 #define pop_mode_and_sreg() { beam_S = (Cell *) *beam_sp++; beam_Mode = (short) *beam_sp++; }
79
80 #define isvar(a) IsVarTerm((Cell) a)
81 #define isappl(a) IsApplTerm((Cell) a)
82 #define ispair(a) IsPairTerm((Cell) a)
83 #define isatom(a) IsAtomOrIntTerm((Cell) a)
84 #define reppair(a) RepPair((Cell) a)
85 #define repappl(a) RepAppl((Cell) a)
86 #define abspair(a) AbsPair((Term *) a)
87 #define absappl(a) AbsAppl((Term *) a)
88
is_perm_var(Cell * a)89 int is_perm_var(Cell *a); inline int is_perm_var(Cell *a) { if (a>=(Cell *) beam_END_BOX && a<(Cell *) (beam_END_BOX+MEM_VARS)) return(1); else return (0); }
90 //int is_perm_var(Cell *a); inline int is_perm_var(Cell *a) { if (a<(Cell *) beam_END_BOX) return(0); else return (1); }
91 //int is_perm_var(Cell *a); inline int is_perm_var(Cell *a) { if ( a<(Cell *) beam_START_ADDR_HEAP || a>=(Cell *) beam_END_BOX) return(1); else return (0); }
92
93 Cell deref(Cell a);
94 int Unify(Cell *a, Cell *b);
95 void UnifyCells(Cell *a, Cell *b);
96 void trail(struct AND_BOX *andbox,struct PERM_VAR *a);
97 void limpa_trail(struct AND_BOX *andbox);
98 void get_arguments(int nr, Cell *a);
99 Cell *save_arguments(int nr);
100 void remove_memory_arguments(Cell *a);
101 void initialize_memory_areas(void);
102 Cell *request_memory(int size);
103 void free_memory(Cell *mem,int size);
104 void limpa_trail_orbox(struct OR_BOX *orbox);
105 struct SUSPENSIONS *addto_suspensions_list(struct AND_BOX *a,int reason);
106 void delfrom_suspensions_list(struct SUSPENSIONS *b);
107 void totop_suspensions_list(struct SUSPENSIONS *b);
108 int verify_externals(struct AND_BOX *and_box);
109 void remove_from_perm_var_suspensions(struct PERM_VAR *v,struct AND_BOX *andbox);
110 void change_perm_var_suspensions(struct PERM_VAR *v,struct AND_BOX *andbox,struct AND_BOX *new);
111 void do_forking_andbox(struct AND_BOX *a);
112 void remove_all_externals(struct AND_BOX *andbox);
113 void remove_all_externals_suspensions(struct AND_BOX *andbox);
114 void del_andbox_and_sons(struct AND_BOX *andbox);
115 void del_orbox_and_sons(struct OR_BOX *orbox);
116 void waking_boxes_suspended_on_var(struct PERM_VAR *v);
117 struct PERM_VAR *request_permVar(struct AND_BOX *a);
118 void free_permVar(struct PERM_VAR *v);
119 Cell *request_memory_locals(int nr);
120 Cell *request_memory_locals_noinit(int nr);
121 void free_memory_locals(Cell *l);
122 void add_to_list_perms(struct PERM_VAR *var,struct AND_BOX *a);
123 void remove_list_perms(struct AND_BOX *a);
124 void move_perm_vars(struct AND_BOX *b, struct AND_BOX *a);
125 void move_perm_variables(struct AND_BOX *a);
126 void inc_level(struct AND_BOX *andbox,int dif);
127 void abort_eam(char *s);
128 void exit_eam(char *s);
129 int HEAP_MEM_FULL(void);
130 void change_from_to(struct PERM_VAR *o,struct PERM_VAR *d);
131 unsigned int index_of_hash_table_atom(Cell c, int nr);
132 unsigned int index_of_hash_table_appl(Cell c, int nr);
133 int deve_limpar_var(struct EXTERNAL_VAR *e);
134 struct status_and *remove_call_from_andbox(struct status_and *ncall, struct AND_BOX *a);
135 int is_leftmost(struct AND_BOX *a, struct status_and *n);
136 int exists_var_in(Cell *c);
137 void garbage_collector(void);
138 void conta_memoria_livre(int size);
139 int showTime(void);
140 struct AND_BOX *choose_leftmost(void);
141 extern Cell BEAM_is(void);
142 extern void do_eam_indexing(struct Predicates *);
143 extern void Yap_plwrite(Term, int (*mywrite) (int, int), int, int);
144
145 #if Debug_Dump_State
146 void dump_eam_state(void);
147 #endif
148
149
150
151 /************************************************************************\
152 * Debug + Status routines *
153 \************************************************************************/
154
conta_memoria_livre(int size)155 void conta_memoria_livre(int size){
156 int i,nr,ult=0;
157 long total=0;
158 Cell *c;
159
160 for(i=0;i<INDEX_SIZE;i++) {
161 nr=0;
162 c=beam_IndexFree[i];
163
164 while(c!=NULL) {
165 ult=i;
166 nr++;
167 c=(Cell *) *c;
168 }
169 total=total+nr*i;
170 }
171 printf("Ultimo Pedido (bytes) =%d � Ultimo bloco livre=%d\n",size,(int) ult*CELL_SIZE);
172 printf("Memoria TOTAL (bytes) =%ld \n",((unsigned long) beam_END_BOX)-((unsigned long) beam_START_ADDR_BOXES));
173 printf("Memoria livre no IndexFree=%ld \n",total*CELL_SIZE);
174 printf("Memoria Total livre =%ld \n",total*CELL_SIZE+((unsigned long) beam_END_BOX)-((unsigned long)beam_NextFree));
175 printf("Memoria Total na HEAP=%ld livre=%ld \n",(unsigned long) MEM_H,(unsigned long) beam_H-(unsigned long) beam_START_ADDR_HEAP);
176 }
177
abort_eam(char * s)178 void abort_eam(char *s)
179 {
180 printf("%s\n",s);
181 exit(1);
182 }
183
exit_eam(char * s)184 void exit_eam(char *s)
185 {
186 printf("%s\n",s);
187 if (beam_nr_call_forking) printf("%d forks executed\n",beam_nr_call_forking);
188
189 if (beam_nr_gc_heap)
190 printf("GC was called %d times on Heap Mem\n",beam_nr_gc_heap);
191 if (beam_nr_gc_boxed)
192 printf("GC was called %d times on Boxed Mem\n",beam_nr_gc_boxed);
193 if (beam_nr_gc_boxed && beam_nr_gc_heap)
194 printf("GC was called %d times \n",beam_nr_gc_boxed+beam_nr_gc_heap);
195
196 #if Memory_Stat
197 {unsigned long req, used;
198 req=beam_TOTAL_MEM+beam_TOTAL_PERMS;
199 used=(beam_TOTAL_MEM+beam_TOTAL_PERMS)-(beam_MEM_REUSED+beam_PERMS_REUSED);
200
201 printf("-------------------------------------------------------------------\n");
202 printf("Total Mem: Requested %ld (%.2fKb) (%.2fMb) \n", req, req/1024.0, req/1048576.0);
203 printf(" Used %ld (%.2fKb) (%.2fMb) / Reused (%3.2f%c)\n", used,used/1024.0, used/1048576.0, (float) (req-used)/req*100,'%');
204 printf("-------------------------------------------------------------------\n");
205
206 used=(beam_TOTAL_MEM-beam_TOTAL_TEMPS)-(beam_MEM_REUSED-beam_TEMPS_REUSED);
207 printf("Boxed Mem: Requested %ld (%.2fKb) (%.2fMb) \n", beam_TOTAL_MEM-beam_TOTAL_TEMPS, (beam_TOTAL_MEM-beam_TOTAL_TEMPS)/1024.0, (beam_TOTAL_MEM-beam_TOTAL_TEMPS)/1048576.0);
208 printf(" Used %ld (%.2fKb) (%.2fMb) / Reused (%3.2f%c)\n", used, used/1024.0, used/1048576.0, (float) (beam_MEM_REUSED-beam_TEMPS_REUSED)/(beam_TOTAL_MEM-beam_TOTAL_TEMPS)*100,'%');
209
210 used=beam_TOTAL_TEMPS-beam_TEMPS_REUSED;
211 printf("Temps Mem: Requested %ld (%.2fKb) (%.2fMB)\n", beam_TOTAL_TEMPS, beam_TOTAL_TEMPS/1024.0, beam_TOTAL_TEMPS/1048576.0);
212 printf(" Used %ld (%.2fKb) (%.2fMb) / Reused (%3.2f%c)\n", used, used/1024.0,used/1048576.0,(float) beam_TEMPS_REUSED/(beam_TOTAL_TEMPS)*100,'%');
213
214
215 used=beam_TOTAL_PERMS-beam_PERMS_REUSED;
216 printf("Perms Mem: Requested %ld (%.2fKb) (%.2fMB)\n", beam_TOTAL_PERMS, beam_TOTAL_PERMS/1024.0, beam_TOTAL_PERMS/1048576.0);
217 printf(" Used %ld (%.2fKb) (%.2fMb) / Reused (%3.2f%c)\n", used, used/1024.0,used/1048576.0,(float) beam_PERMS_REUSED/(beam_TOTAL_PERMS)*100,'%');
218 }
219 printf("-------------------------------------------------------------------\n");
220 if (beam_nr_gc_boxed+beam_nr_gc_heap>0) {
221 int i;
222 beam_Memory_STAT[0][0]=0; beam_Memory_STAT[0][1]=0; beam_Memory_STAT[0][2]=0; beam_Memory_STAT[0][3]=0; beam_Memory_STAT[0][4]=0;
223 for(i=1;i<=beam_nr_gc_boxed+beam_nr_gc_heap;i++) {
224 beam_Memory_STAT[0][0]+=beam_Memory_STAT[i][0];
225 beam_Memory_STAT[0][1]+=beam_Memory_STAT[i][1];
226 beam_Memory_STAT[0][2]+=beam_Memory_STAT[i][2];
227 beam_Memory_STAT[0][3]+=beam_Memory_STAT[i][3];
228 beam_Memory_STAT[0][4]+=beam_Memory_STAT[i][4];
229 printf("GC %4d Time=%ld H=%ld to %ld (%3.2f) Box=%ld to %ld (%3.2f)\n",
230 i, beam_Memory_STAT[i][0], beam_Memory_STAT[i][1], beam_Memory_STAT[i][3],
231 ((float) beam_Memory_STAT[i][3]/beam_Memory_STAT[i][1])*100 , beam_Memory_STAT[i][2], beam_Memory_STAT[i][4],
232 ((float) beam_Memory_STAT[i][4]/beam_Memory_STAT[i][2])*100);
233 }
234 i--;
235 printf("\nRESUME GC: Time=%ld H=%ld to %ld (%3.2f) Box=%ld to %ld (%3.2f)\n",
236 beam_Memory_STAT[0][0]/i, beam_Memory_STAT[0][1]/i, beam_Memory_STAT[0][3]/i,
237 100.0-((float) beam_Memory_STAT[0][3]/beam_Memory_STAT[0][1])*100 , beam_Memory_STAT[0][2]/i, beam_Memory_STAT[0][4]/i,
238 100.0-((float) beam_Memory_STAT[0][4]/beam_Memory_STAT[0][2])*100);
239
240 } else {
241 printf("Heap Mem Requested %ld (%.2fKb) (%.2fMB) \n", ((unsigned long) beam_H-beam_START_ADDR_HEAP), ((unsigned long) beam_H-beam_START_ADDR_HEAP)/1024.0, ((unsigned long) beam_H-beam_START_ADDR_HEAP)/1048576.0);
242 printf("-------------------------------------------------------------------\n");
243 }
244 #endif
245 exit(0);
246 }
247
248
249 /************************************************************************\
250 * Memory Management routines *
251 \************************************************************************/
252
initialize_memory_areas()253 void initialize_memory_areas()
254 {
255 static int first_time=1;
256
257 if (first_time) {
258 first_time=0;
259 beam_IndexFree=(Cell **) malloc(INDEX_SIZE*POINTER_SIZE);
260 if ((void *) beam_IndexFree==(void *)NULL) abort_eam("Memory Initialization Error IndexFree\n");
261
262 beam_START_ADDR_HEAP=(unsigned long) malloc(MEM_H+MEM_BOXES+MEM_VARS);
263 if ((void *)beam_START_ADDR_HEAP==(void *)NULL) abort_eam("Memory Initialization Error Heap+Boxes\n");
264 beam_START_ADDR_BOXES=beam_START_ADDR_HEAP+MEM_H;
265 beam_END_H=beam_START_ADDR_HEAP+MEM_H;
266 beam_END_BOX=beam_START_ADDR_BOXES+MEM_BOXES;
267 }
268
269 beam_sp=(Cell *) beam_END_H; beam_sp-=2;
270
271 beam_NextVar=(struct PERM_VAR *) beam_END_BOX;
272 beam_H=(Cell *) beam_START_ADDR_HEAP;
273 #if GARBAGE_COLLECTOR!=2
274 beam_NextFree=(Cell *) beam_END_BOX;
275 #else
276 beam_NextFree=(Cell *) beam_START_ADDR_BOXES;
277 #endif
278 beam_MemGoing=1;
279 memset(beam_IndexFree,0,INDEX_SIZE*POINTER_SIZE);
280 { int i,max;
281 max=MEM_VARS/PERM_VAR_SIZE;
282 for(i=0;i<max-1;i++) {
283 beam_NextVar[i].next=&beam_NextVar[i+1];
284 }
285 beam_NextVar[max-1].next=NULL;
286 }
287
288 beam_varlocals=NULL;
289 beam_USE_SAME_ANDBOX=NULL;
290 beam_nr_alternative=NULL;
291 beam_nr_call=NULL;
292 beam_nr_gc_heap=0;
293 beam_nr_gc_boxed=0;
294 beam_Mode=READ;
295 beam_VAR_TRAIL_NR=0;
296 beam_nr_call_forking=0;
297 beam_Mem_FULL=0;
298 #if Memory_Stat
299 beam_TOTAL_MEM=0; beam_MEM_REUSED=0; beam_TOTAL_TEMPS=0; beam_TEMPS_REUSED=0; beam_TOTAL_PERMS=0; beam_PERMS_REUSED=0;
300 memset(beam_Memory_STAT,0,MAX_MEMORYSTAT*5*sizeof(unsigned long));
301 #endif
302 }
303
HEAP_MEM_FULL(void)304 INLINE int HEAP_MEM_FULL(void)
305 {
306 if (beam_MemGoing==1) {
307 if ((unsigned long)beam_H>(unsigned long)(beam_START_ADDR_HEAP+MEM_H/2)) {
308 beam_Mem_FULL|=2;
309 }
310 } else {
311 if ((unsigned long) beam_H>(unsigned long)(beam_START_ADDR_HEAP+MEM_H)) {
312 beam_Mem_FULL|=2;
313 }
314 }
315
316 return(beam_Mem_FULL);
317 }
318
319
request_memory(int size)320 INLINE Cell *request_memory(int size) /* size in bytes */
321 {
322 register Cell *mem;
323 register int size_cells;
324
325 if (size==0) return NULL;
326 size_cells=size/CELL_SIZE;
327
328 #if !Fast_go
329 if (size_cells> INDEX_SIZE)
330 abort_eam("Foi pedido um block de memoria grande demais !!! \n");
331 #endif
332
333 #if Debug & Debug_MEMORY
334 printf("Requesting memory size %d\n",size_cells);
335 #endif
336
337 #if HYBRID_BOXMEM
338 mem=beam_IndexFree[(unsigned) size_cells];
339 #if Memory_Stat
340 beam_TOTAL_MEM+=size;
341 if (mem!=NULL) beam_MEM_REUSED+=size;
342 #endif
343 if (mem==NULL) {
344
345 #else /* GC Only */
346 #if Memory_Stat
347 beam_TOTAL_MEM+=size;
348 #endif
349 if (1) {
350 #endif
351
352 #if GARBAGE_COLLECTOR!=2
353 beam_NextFree-=size_cells;
354 mem=beam_NextFree;
355 if (beam_NextFree< (Cell *) beam_START_ADDR_BOXES) abort_eam("No more BOX_MEM \n");
356 #else
357 if (beam_MemGoing==1) {
358 mem=beam_NextFree;
359 beam_NextFree+=size_cells;
360 if (beam_NextFree> (Cell *) ( beam_START_ADDR_BOXES+MEM_BOXES/2)) beam_Mem_FULL |= 1;
361 } else {
362 beam_NextFree-=size_cells;
363 mem=beam_NextFree;
364 if (beam_NextFree< (Cell *) ( beam_START_ADDR_BOXES+MEM_BOXES/2)) beam_Mem_FULL |=1;
365 }
366 #endif
367 } else {
368 beam_IndexFree[(unsigned) size_cells]=(Cell *) *mem;
369 }
370
371 #if Clear_MEMORY & 1
372 memset(mem,0,size); /* NOT REALLY NECESSARY, use only to detect possible errors*/
373 #endif
374
375 return(mem);
376 }
377
378 #if HYBRID_BOXMEM==0
379 void free_memory(Cell *mem,int size) {
380 #if Clear_MEMORY & 2
381 memset(mem,0,size);
382 #endif
383 };
384 #else
385 INLINE void free_memory(Cell *mem,int size) /* size in bytes */
386 {
387 register int size_cells;
388
389 if (size==0 || mem==NULL) return;
390
391 size_cells=size/CELL_SIZE;
392
393 #if Clear_MEMORY & 2
394 memset(mem,0,size); /* NOT REALLY NECESSARY, use only to detect possible errors*/
395 #endif
396
397 #if Debug & Debug_MEMORY
398 printf("Freeing memory size %d\n",size_cells);
399 #endif
400
401 *mem=(Cell) beam_IndexFree[size_cells];
402 beam_IndexFree[size_cells]=mem;
403 }
404 #endif
405
406 INLINE void get_arguments(int nr, Cell *a)
407 {
408 register int i;
409 for(i=1;i<=nr;i++) beam_X[i]=a[i];
410 }
411
412 INLINE Cell *save_arguments(int nr) /* nr arguments */
413 {
414 if (!nr) return(NULL);
415 {
416 register int i;
417 register Cell *a;
418
419 a=(Cell *)request_memory((nr+1)*CELL_SIZE);
420 a[0]=nr+1;
421 for(i=1;i<=nr;i++) a[i]=beam_X[i];
422 return(a);
423 }
424 }
425
426 INLINE void remove_memory_arguments(Cell *a)
427 {
428 if (a==NULL) return;
429 #if !Fast_go
430 if (a[0]<1 || a[0]>1000)
431 printf("%d Numero Invalido de Argumentos............\n",a[0]);
432 #endif
433
434 free_memory(a,a[0]*CELL_SIZE);
435 }
436
437 struct PERM_VAR *request_permVar(struct AND_BOX *a) {
438 struct PERM_VAR *pv;
439
440 #if Memory_Stat
441 static struct PERM_VAR *old=NULL;
442 beam_TOTAL_PERMS+=PERM_VAR_SIZE;
443 if (old<=beam_NextVar) old=beam_NextVar;
444 else beam_PERMS_REUSED+=PERM_VAR_SIZE;
445 #endif
446
447 #if Debug && Debug_MEMORY
448 printf("Requesting a permVar...\n");
449 #endif
450
451 #if !Fast_go
452 if (beam_NextVar->next==NULL) { printf("Fim da memoria para variaveis\n"); exit (-1); }
453 #endif
454
455 pv=beam_NextVar;
456 beam_NextVar=beam_NextVar->next;
457
458 pv->value=(Cell) &(pv->value);
459 pv->home=a;
460 pv->suspensions=NULL;
461 pv->yapvar=NULL;
462 pv->next=a->perms;
463 a->perms=pv;
464 return (pv);
465 }
466
467 void free_permVar(struct PERM_VAR *v) {
468 #if Clear_MEMORY
469 v->value=(Cell) NULL;
470 v->home=(struct AND_BOX *) NULL;
471 v->suspensions=(struct SUSPENSIONS_VAR *) NULL;
472 #endif
473
474 #if Debug & Debug_MEMORY
475 printf("Freeing a permVar...\n");
476 #endif
477
478 v->next=beam_NextVar;
479 beam_NextVar=v;
480 return;
481 }
482
483
484 INLINE Cell *request_memory_locals(int nr)
485 {
486 Cell *l;
487 int i;
488
489 #if Memory_Stat
490 Cell *old;
491 old=beam_NextFree;
492 beam_TOTAL_TEMPS+=CELL_SIZE*(nr+1);
493 #endif
494
495 #if Debug_MEMORY
496 printf("Requesting Memory for %d+1 locals...\n",nr);
497 #endif
498
499
500 l=(Cell *)request_memory(CELL_SIZE*(nr+1));
501 l[0]=nr;
502 l++;
503
504 for(i=0;i<nr;i++) {
505 l[i]=(Cell) &l[i];
506 }
507
508 #if Memory_Stat
509 if (old==beam_NextFree) beam_TEMPS_REUSED+=CELL_SIZE*(nr+1);
510 #endif
511
512 return(l);
513 }
514
515 INLINE Cell *request_memory_locals_noinit(int nr)
516 {
517 Cell *l;
518
519 #if Memory_Stat
520 Cell *old;
521 old=beam_NextFree;
522 beam_TOTAL_TEMPS+=CELL_SIZE*(nr+1);
523 #endif
524
525 #if Debug_MEMORY
526 printf("Requesting Memory for %d+1 locals (not initialized)...\n",nr);
527 #endif
528
529
530 l=(Cell *)request_memory(CELL_SIZE*(nr+1));
531 l[0]=nr;
532 l++;
533
534 #if Memory_Stat
535 if (old==beam_NextFree) beam_TEMPS_REUSED+=CELL_SIZE*(nr+1);
536 #endif
537
538 return(l);
539 }
540
541 INLINE void free_memory_locals(Cell *l)
542 {
543 if (l==NULL || l[-1]==0) return;
544
545 #if Debug_MEMORY
546 printf("Freeing Memory for %ld+1 locals...\n",l[-1]);
547 #endif
548
549 free_memory((Cell *) &l[-1], CELL_SIZE*(l[-1]+1));
550 l[-1]=0; /* � necess�rio para evitar apagar este vector novamente
551 porque varias calls podem estar a referenciar o mesmo vector locals */
552 }
553
554
555
556
557 /************************************************************************\
558 * Manipulating And-Or-Boxes structures *
559 \************************************************************************/
560
561
562
563 void del_andbox_and_sons(struct AND_BOX *andbox )
564 {
565 register struct status_and *ncall;
566
567 if (andbox==NULL) return;
568
569 remove_all_externals(andbox);
570 delfrom_suspensions_list(andbox->suspended);
571
572 ncall=andbox->calls;
573 while(ncall!=NULL) {
574 del_orbox_and_sons(ncall->call);
575 {
576 struct status_and *ncall_old;
577 ncall_old=ncall;
578 ncall=ncall->next;
579 free_memory_locals(ncall_old->locals);
580 free_memory((Cell *) ncall_old,STATUS_AND_SIZE);
581 }
582 }
583 remove_list_perms(andbox);
584 free_memory((Cell *) andbox,ANDBOX_SIZE);
585 }
586
587 void del_orbox_and_sons(struct OR_BOX *orbox)
588 {
589 struct status_or *so;
590 Cell *a=NULL;
591
592 if (orbox==NULL) return;
593
594 so=orbox->alternatives;
595 while (so!=NULL) {
596 struct status_or *old;
597 del_andbox_and_sons(so->alternative);
598 a=so->args;
599 old=so;
600 so=so->next;
601 free_memory((Cell *) old,STATUS_OR_SIZE);
602 }
603 remove_memory_arguments(a); /* remove args */
604 free_memory((Cell *) orbox,ORBOX_SIZE);
605 }
606
607
608 INLINE struct status_and *remove_call_from_andbox(struct status_and *ncall, struct AND_BOX *a)
609 {
610 register int nr;
611 struct status_and *r;
612 nr=a->nr_all_calls;
613 nr--;
614 a->nr_all_calls=nr;
615 if (nr==0) {
616 a->calls=NULL;
617 } else {
618 if (ncall->previous!=NULL) {
619 ncall->previous->next=ncall->next;
620 } else a->calls=ncall->next;
621
622 if (ncall->next!=NULL) {
623 ncall->next->previous=ncall->previous;
624 }
625 }
626
627 r=ncall->next;
628 { /* vou ver se as locals ainda estao a ser usadas por outra ncall */
629 int aSerUsada=0;
630 struct status_and *l;
631 l=ncall->previous;
632 while (l!=NULL) {
633 if (l->locals==ncall->locals) { aSerUsada=1; break; }
634 l=l->previous;
635 }
636 l=r;
637 while (aSerUsada==0 && l!=NULL) {
638 if (l->locals==ncall->locals) { aSerUsada=1; break; }
639 l=l->next;
640 }
641 // aSerUsada=1; /* CUIDADO ao apagar as var locals da call */
642 if (aSerUsada==0) free_memory_locals(ncall->locals);
643 }
644 free_memory((Cell *) ncall,STATUS_AND_SIZE);
645 return(r);
646 }
647
648
649
650 INLINE void totop_suspensions_list(struct SUSPENSIONS *b)
651 {
652 if (beam_su==b) return; /* is already on top of list */
653 if (beam_su->prev==b) { beam_su=b; return; } /* It was the last one */
654
655 b->prev->next=b->next;
656 b->next->prev=b->prev;
657
658 b->next=beam_su;
659 b->prev=beam_su->prev;
660 beam_su->prev=b;
661 b->prev->next=b;
662 beam_su=b;
663 }
664
665 void waking_boxes_suspended_on_var(struct PERM_VAR *v)
666 {
667 struct SUSPENSIONS_VAR *s;
668
669 s=v->suspensions;
670
671 while(s!=NULL) {
672 register struct AND_BOX *a;
673 #if Debug
674 printf("Waking and_box assigment changed on a var that forced and_box to suspend \n");
675 #endif
676 a=s->and_box;
677 totop_suspensions_list(a->suspended);
678 a->nr_alternative->state|=WAKE;
679 s=s->next;
680 }
681 }
682
683 /* THE FALLOWING ROTINES ARE TO BE APPLYED TO THE SUSPENSION LIST
684 (DO NOT USE IT TO THE SUSPENSIONS ON THE LOCAL_VAR) */
685 INLINE struct SUSPENSIONS *addto_suspensions_list(struct AND_BOX *a,int r)
686 {
687 struct SUSPENSIONS *s;
688
689 if (a->suspended) return(a->suspended); /* already suspended */
690
691 s=(struct SUSPENSIONS *) request_memory(SUSPENSIONS_SIZE);
692 s->and_box=a;
693 s->reason=r;
694 if (beam_su==NULL) {
695 s->next=s;
696 s->prev=s;
697 beam_su=s;
698 } else {
699 s->next=beam_su;
700 s->prev=beam_su->prev;
701 beam_su->prev=s;
702 if (beam_su->next==beam_su) { /* so existem 2 elementos na lista */
703 beam_su->next=s;
704 } else {
705 s->prev->next=s;
706 }
707 }
708
709 return(s);
710 }
711
712
713 void delfrom_suspensions_list(struct SUSPENSIONS *b)
714 {
715 if (b==NULL) return;
716 #if !Fast_go
717 if ( b->and_box->suspended==NULL)
718 abort_eam("Nunca deveria acontecer no delfrom_suspensions_list ?????\n");
719 #endif
720
721 remove_all_externals_suspensions(b->and_box);
722 b->and_box->suspended=NULL;
723
724 if (b==beam_su) beam_su=b->next;
725
726 if (b==beam_su) { /* so existe um */
727 beam_su=NULL;
728 } else {
729 b->prev->next=b->next;
730 b->next->prev=b->prev;
731 }
732 free_memory((Cell *) b,SUSPENSIONS_SIZE);
733 }
734
735
736 INLINE void change_perm_var_suspensions(struct PERM_VAR *v,struct AND_BOX *andbox,struct AND_BOX *new)
737 {
738 struct SUSPENSIONS_VAR *s;
739
740 s=v->suspensions;
741 while(s!=NULL)
742 {
743 if (s->and_box==andbox) {
744 s->and_box=new;
745 return;
746 }
747 s=s->next;
748 }
749 }
750
751
752
753
754
755 /* MANIPULATE PERM VARS SUSPENSIONS */
756
757 INLINE void remove_from_perm_var_suspensions(struct PERM_VAR *v,struct AND_BOX *andbox)
758 {
759 struct SUSPENSIONS_VAR *s,*prev=NULL;
760
761 if (v==NULL) {
762 #if !Fast_go
763 abort_eam("Nunca deveria acontecer no remove_from_perm_var_suspensions ?????\n");
764 #endif
765 return;
766 }
767
768 s=v->suspensions;
769 while(s!=NULL)
770 {
771 struct SUSPENSIONS_VAR *next;
772 next=s->next;
773 if (s->and_box==andbox) {
774 if (prev==NULL) {
775 v->suspensions=s->next;
776 } else prev->next=s->next;
777 free_memory((Cell *) s,SUSPENSIONS_VAR_SIZE);
778 } else { /* acordar as boxes restantes porque houve uma alteracao */
779 s->and_box->nr_alternative->state |=WAKE;
780 prev=s;
781 }
782 s=next;
783 }
784 }
785
786 void remove_all_externals_suspensions(struct AND_BOX *andbox)
787 {
788 struct EXTERNAL_VAR *e;
789
790 e=andbox->externals;
791 while(e) {
792 remove_from_perm_var_suspensions(e->var,andbox);
793 e=e->next;
794 }
795 }
796
797 void remove_all_externals(struct AND_BOX *andbox)
798 {
799 struct EXTERNAL_VAR *e;
800
801 e=andbox->externals;
802 while(e) {
803 struct EXTERNAL_VAR *next;
804 next=e->next;
805 remove_from_perm_var_suspensions(e->var,andbox);
806 free_memory((Cell *)e,EXTERNAL_VAR_SIZE);
807 e=next;
808 }
809 }
810
811 void remove_list_perms(struct AND_BOX *a)
812 {
813 struct PERM_VAR *l,*oldl;
814
815 l=a->perms;
816 a->perms=NULL;
817 while(l) {
818 oldl=l;
819 l=oldl->next;
820 free_permVar(oldl);
821 }
822 }
823
824
825 INLINE void move_perm_vars(struct AND_BOX *b, struct AND_BOX *a) /* (from b to a) */
826 {
827 struct PERM_VAR *l,*old;
828
829 l=b->perms;
830 if (l==NULL) return;
831 do {
832 old=l;
833 l->home=a;
834 if (l->suspensions) change_perm_var_suspensions(l,b,a);
835 l=l->next;
836 } while(l!=NULL);
837 old->next=a->perms;
838 a->perms=b->perms;
839 return;
840 }
841
842 void add_to_list_perms(struct PERM_VAR *var,struct AND_BOX *a)
843 {
844 var->next=a->perms;
845 a->perms=var;
846 return;
847 }
848
849 /* change all suspended external references of perm var o to perm var d */
850 void change_from_to(struct PERM_VAR *o,struct PERM_VAR *d) {
851 struct SUSPENSIONS_VAR *s,*last;
852
853 #if Debug
854 printf("Change Vars from one andbox to another\n");
855 #endif
856
857 s=o->suspensions;
858 if (s==NULL) return;
859 /* CUIDADO - Don't Forget to Write de Code to verify if they are compatible */
860 /* second change the references of o to point to d, also change suspensions from o to d */
861 do {
862 struct EXTERNAL_VAR *e;
863 #if Debug
864 struct SUSPENSIONS_VAR *l;
865 l=d->suspensions;
866 while(l!=NULL) {
867 if (l->and_box==s->and_box) {
868 printf("Same and-box binding... must check for compatibility.......!!!!");
869 }
870 l=l->next;
871 }
872 #endif
873
874 e=s->and_box->externals;
875 while(e!=NULL) {
876 if (e->var==o) {
877 e->var=d;
878 }
879 e=e->next;
880 }
881
882 last=s;
883 s=s->next;
884 } while(s);
885 last->next=d->suspensions;
886 d->suspensions=o->suspensions;
887 o->suspensions=NULL;
888
889 }
890
891
892 /************************************************************************\
893 * Other routines *
894 \************************************************************************/
895
896 void inc_level(struct AND_BOX *andbox,int dif)
897 {
898 struct OR_BOX *orbox;
899 struct status_and *calls;
900
901 if (andbox==NULL) return;
902
903 andbox->level+=dif;
904 calls=andbox->calls;
905 while(calls!=NULL) {
906 orbox=calls->call;
907 if (orbox!=NULL) {
908 struct status_or *so;
909 so=orbox->alternatives;
910 while (so!=NULL) {
911 inc_level(so->alternative,dif);
912 so=so->next;
913 }
914 }
915 calls=calls->next;
916 }
917 }
918
919
920 INLINE int is_leftmost(struct AND_BOX *a, struct status_and *n)
921 {
922 if (a==beam_top) return(1);
923 if (a->calls!=n) return(0);
924 if (a->nr_alternative->previous!=NULL) return(0);
925
926 return(is_leftmost(a->parent->parent,a->parent->nr_call));
927 }
928
929 struct AND_BOX *choose_leftmost(void)
930 {
931 struct AND_BOX *a;
932 struct OR_BOX *o=NULL;
933 struct status_and *ncall;
934
935 a=beam_top;
936 do {
937 ncall=a->calls;
938 if (ncall==NULL) break;
939 while(ncall!=NULL) {
940 o=ncall->call;
941 if (o!=NULL) break;
942 ncall=ncall->next;
943 }
944 if (ncall==NULL) break;
945 a=o->alternatives->alternative;
946 if (a==NULL) { beam_OBX=o; return(a); }
947 } while(1);
948
949 return a;
950 }
951
952 INLINE unsigned int index_of_hash_table_atom(Cell c, int nr)
953 {
954 return (((unsigned long) c >>3) % nr);
955 }
956
957 INLINE unsigned int index_of_hash_table_appl(Cell c, int nr)
958 {
959 return (((unsigned long) c >>5) % nr);
960 }
961
962
963 /************************************************************************\
964 * Unification routines *
965 \************************************************************************/
966
967 void trail(struct AND_BOX *andbox,struct PERM_VAR *v)
968 {
969 register struct EXTERNAL_VAR *e;
970 int var_level;
971
972 if (!is_perm_var((Cell *) v)) return;
973 var_level=(v->home)->level;
974 if (var_level>=andbox->level) { /* Don't Need to Trail */
975 waking_boxes_suspended_on_var(v); /* Really Not Needed, just to speedup avoiding forks */
976 if (isvar(v->value)) { /* CUIDADO posso ter de fazer deref primeiro */
977 change_from_to(v,(struct PERM_VAR *) *((Cell *) v->value));
978 }
979 return;
980 }
981
982 #if Debug
983 printf("Trailing var 0x%lX on ANDBOX 0x%lX\n", (unsigned long) v, (unsigned long) andbox);
984 #endif
985 e=(struct EXTERNAL_VAR *) request_memory(EXTERNAL_VAR_SIZE);
986 e->next=andbox->externals;
987 andbox->externals=e;
988 e->var=v;
989 e->value=v->value;
990 }
991
992 INLINE int deve_limpar_var(struct EXTERNAL_VAR *e)
993 {
994 return(e->var->value==e->value && isvar(e->var) ); /* ????? */
995 }
996
997 void limpa_trail(struct AND_BOX *andbox)
998 {
999 struct EXTERNAL_VAR *e;
1000 Cell *l;
1001
1002 if (andbox==NULL) return;
1003
1004 e=andbox->externals;
1005 while(e!=NULL) {
1006 if (deve_limpar_var(e)) {
1007 l=(Cell *) e->var;
1008 *((Cell *) l)=(Cell) l;
1009 }
1010 e=e->next;
1011 }
1012 { register struct status_and *ncall;
1013 ncall=andbox->calls;
1014 while(ncall) {
1015 register struct OR_BOX *o;
1016 o=ncall->call;
1017 if (o!=NULL) {
1018 struct status_or *so;
1019 so=o->alternatives;
1020 while (so!=NULL) {
1021 limpa_trail(so->alternative);
1022 so=so->next;
1023 }
1024 }
1025 ncall=ncall->next;
1026 }
1027 }
1028 }
1029
1030
1031 INLINE void limpa_trail_orbox(struct OR_BOX *orbox)
1032 {
1033 struct status_or *so;
1034
1035 so=orbox->alternatives;
1036 while(so!=NULL) {
1037 limpa_trail(so->alternative);
1038 so=so->next;
1039 }
1040 }
1041
1042 INLINE Cell deref(Cell a)
1043 {
1044 register Cell *b;
1045
1046 while(isvar(a)) {
1047 b = (Cell *) a;
1048 a = *b;
1049 if(a==((Cell) b)) return a;
1050 }
1051 return a;
1052 }
1053
1054 void UnifyCells(Cell *a, Cell *b) /* a e b variaveis */
1055 {
1056
1057 if(a==b) return;
1058 if (is_perm_var(a)) {
1059 if (is_perm_var(b)) {
1060 register int i,j;
1061 i=((struct PERM_VAR *) a)->home->level;
1062 j=((struct PERM_VAR *) b)->home->level;
1063 if (i<j) {
1064 *b=(Cell) a;
1065 trail(beam_ABX,(struct PERM_VAR *) b);
1066 return;
1067 } else {
1068 *a=(Cell) b;
1069 trail(beam_ABX,(struct PERM_VAR *) a);
1070 return;
1071 }
1072 } else {
1073 *b=(Cell) a;
1074 return;
1075 }
1076 }
1077 *a=(Cell) b;
1078 return;
1079 }
1080
1081 int Unify(Cell *a, Cell *b)
1082 {
1083 a = (Cell *) deref((Cell) a);
1084 b = (Cell *) deref((Cell) b);
1085 if(isvar(a)) {
1086 if(isvar(b)) {
1087 UnifyCells(a,b);
1088 return 1;
1089 }
1090 { *a=(Cell) b; trail(beam_ABX,(struct PERM_VAR *)a); }
1091 return 1;
1092 }
1093 if(isvar(b)) {
1094 { *b=(Cell) a; trail(beam_ABX,(struct PERM_VAR *)b); }
1095 return 1;
1096 }
1097 if(a==b) return 1;
1098 if(isappl(a)) {
1099 int arity;
1100 if(!isappl(b)) return 0;
1101 a = (Cell *) repappl(a);
1102 b = (Cell *) repappl(b);
1103 if(*a != *b) return 0;
1104 arity = ((int) ArityOfFunctor((Functor) *a));
1105 while(arity!=0) {
1106 if(!Unify((Cell *)a[arity], (Cell *)b[arity])) return 0;
1107 --arity;
1108 }
1109 return 1;
1110 }
1111 if(ispair(a)) {
1112 if(!ispair(b)) return 0;
1113 a = (Cell *) reppair(a);
1114 b = (Cell *) reppair(b);
1115 if(!Unify((Cell *)*a,(Cell *)*b)) return 0;
1116 return Unify((Cell *)a[1],(Cell *) b[1]);
1117 }
1118 if(a!=b) return 0;
1119 return 1;
1120 }
1121
1122
1123
1124 int verify_externals(struct AND_BOX *andbox)
1125 {
1126 struct EXTERNAL_VAR *e,*prev;
1127
1128 #if Debug
1129 printf("Entering Verify Externals \n");
1130 #endif
1131 e=andbox->externals;
1132 prev=NULL;
1133
1134 while(e) {
1135 Cell d;
1136 d=deref((Cell) e->var); /* e->var->value */
1137 if (!isvar(d)) { /* ja nao e' var */
1138 if (isvar(e->value)) {
1139 struct PERM_VAR *old,*new;
1140 struct SUSPENSIONS_VAR *s;
1141
1142 old=e->var;
1143 new=(struct PERM_VAR *) e->value;
1144 e->var=new;
1145 e->value=(Cell) old;
1146 remove_from_perm_var_suspensions(old,andbox);
1147 s=(struct SUSPENSIONS_VAR *) request_memory(SUSPENSIONS_VAR_SIZE);
1148 s->and_box=andbox;
1149 s->next=new->suspensions;
1150 new->suspensions=s;
1151 if (e->var->home->level==andbox->level) { /* ja nao e' uma var externa */
1152 e->var->value=e->value;
1153 goto tudo_ok;
1154 }
1155 prev=e;
1156 e=e->next;
1157 continue;
1158 } else {
1159 if (Unify((Cell *) d,(Cell *) e->value)) {
1160 /* Preciso de ter cuidado pois podem ter sido criadas External Vars */
1161 if (prev==NULL && andbox->externals!=e) {
1162 prev=andbox->externals;
1163 while (prev->next!=e) prev=prev->next;
1164 }
1165 goto tudo_ok;
1166 }
1167 #if Debug
1168 printf("Verify Externals Has failed \n");
1169 #endif
1170 return(0);
1171 }
1172 } else { /* ainda e' var */
1173 if (e->var->home->level==andbox->level) { /* ja nao e' uma var externa */
1174 /* e->var->value=e->value; */
1175 *((Cell *) d)=e->value;
1176 tudo_ok:
1177 /* primeiro remover a andbox da lista de suspensoes da variavel */
1178 remove_from_perm_var_suspensions(e->var,andbox);
1179 waking_boxes_suspended_on_var(e->var);
1180
1181 /* remover a variavel da lista de externals */
1182 if (prev==NULL) { /* a var e' a primeira da lista */
1183 andbox->externals=e->next;
1184 free_memory((Cell *)e,EXTERNAL_VAR_SIZE);
1185 e=andbox->externals;
1186 continue;
1187 } else {
1188 prev->next=e->next;
1189 free_memory((Cell *)e,EXTERNAL_VAR_SIZE);
1190 e=prev->next;
1191 continue;
1192 }
1193 }
1194 }
1195
1196 prev=e;
1197 e=e->next;
1198 }
1199
1200 if (andbox->externals==NULL) { /* Se ja nao ha external vars posso remover andbox da lista suspensions */
1201 delfrom_suspensions_list(andbox->suspended);
1202 }
1203 #if Debug
1204 printf("Verify Externals Has ended with Sucess\n");
1205 #endif
1206
1207 return(1); /* Means OK */
1208 }
1209
1210 int exists_var_in(Cell *c)
1211 {
1212 Cell *C, *OldC;
1213
1214 OldC=(Cell *) deref((Cell) c);
1215
1216 if (isvar(OldC)) {
1217 return(1);
1218 }
1219 if (isatom(OldC)) {
1220 return(0);
1221 }
1222
1223 if (ispair(OldC)) {
1224 C=(Cell *) reppair(OldC);
1225 return(exists_var_in(C) || exists_var_in(++C));
1226 }
1227
1228 return(0);
1229 }
1230
1231
1232 /************************************************************************\
1233 * Emulador de EAM *
1234 \************************************************************************/
1235
1236
1237 void give_solution_toyap(void);
1238 void give_solution_toyap(void) {
1239 struct PERM_VAR *l;
1240 l=beam_ABX->perms;
1241 while(l) {
1242 if (l->yapvar) {
1243 *TR=(Cell) l->yapvar;
1244 TR++;
1245 *(l->yapvar)=l->value;
1246 }
1247 l=l->next;
1248 }
1249 }
1250
1251 void add_vars_to_listperms(struct AND_BOX *a, Cell *arg);
1252 void add_vars_to_listperms(struct AND_BOX *a, Cell *arg) {
1253 Cell *_DR;
1254 Cell *NewC;
1255
1256 _DR=(Cell *) deref((Cell) arg);
1257 if (isvar((Cell *) _DR) && !is_perm_var(_DR)) {
1258 struct PERM_VAR *l;
1259 l=request_permVar(a);
1260 l->yapvar=_DR;
1261 *_DR=(Cell) l;
1262 }
1263 if (isappl(_DR)) {
1264 int i,arity;
1265
1266 NewC=(Cell *) repappl(_DR);
1267 arity = ((int) ArityOfFunctor((Functor) *NewC));
1268 for(i=0;i<arity ;i++) {
1269 NewC++;
1270 add_vars_to_listperms(a,NewC);
1271 }
1272 }
1273 if (ispair(_DR)) {
1274 NewC=(Cell *) reppair(_DR);
1275 add_vars_to_listperms(a,NewC);
1276 NewC++;
1277 add_vars_to_listperms(a,NewC);
1278 NewC++;
1279 }
1280
1281 /* � atomic, posso terminar */
1282 }
1283
1284 PredEntry *prepare_args_torun(void);
1285 PredEntry *prepare_args_torun(void) {
1286 Cell *_DR;
1287 Prop pe;
1288 PredEntry *ppe;
1289
1290 /* at this time, ARG1=call */
1291 _DR=(Cell *) deref(beam_X[1]);
1292
1293 if (isatom(_DR)) {
1294 /* char *name = AtomOfTerm((Term) _DR)->StrOfAE; */
1295
1296 pe = PredPropByAtom(AtomOfTerm((Term) _DR), CurrentModule);
1297 ppe = RepPredProp(pe);
1298
1299 return (ppe);
1300 }
1301
1302 if (isappl(_DR)) {
1303 /* char *name = (NameOfFunctor((Functor) *NewC))->StrOfAE; */
1304 int i, arity;
1305 Functor f = FunctorOfTerm((Term) _DR);
1306 if (IsBlobFunctor(f)) {
1307 Yap_Error(TYPE_ERROR_CALLABLE,(Term) _DR,"call/1");
1308 return(FALSE);
1309 }
1310 pe = PredPropByFunc(f, CurrentModule);
1311 ppe = RepPredProp(pe);
1312
1313 _DR=(Cell *) repappl(_DR);
1314 arity = ArityOfFunctor(f);
1315
1316 for(i=1;i<=arity ;i++) {
1317 _DR++;
1318 beam_X[i]=(Cell) _DR;
1319 }
1320 return (ppe);
1321 }
1322
1323 return (NULL);
1324 }
1325
1326 #if DIRECT_JUMP
1327 #define execute_next() goto **((void **) beam_pc)
1328 Cell *TABLE_OPS=NULL;
1329 #else
1330 #define execute_next() goto *OpAddress[*beam_pc]
1331 #endif
1332
1333
1334
1335 int eam_am(PredEntry *initPred);
1336 int eam_am(PredEntry *initPred)
1337 {
1338 static void *OpAddress[]= {
1339 &&exit_eam,
1340 &&top_tree,
1341 &&scheduler,
1342 &&prepare_tries,
1343 &&prepare_calls,
1344 &&get_var_X,
1345 &&get_var_Y,
1346 &&get_val_X,
1347 &&get_val_Y,
1348 &&get_atom,
1349 &&get_list,
1350 &&get_struct,
1351 &&unify_void,
1352 &&unify_val_X,
1353 &&unify_val_Y,
1354 &&unify_var_X,
1355 &&unify_var_Y,
1356 &&unify_atom,
1357 &&unify_list,
1358 &&unify_last_list,
1359 &&unify_struct,
1360 &&unify_last_struct,
1361 &&unify_last_atom,
1362 &&unify_local_X,
1363 &&unify_local_Y,
1364 &&put_var_X,
1365 &&put_var_Y,
1366 &&put_val_X,
1367 &&put_val_Y,
1368 &&put_atom,
1369 &&put_list,
1370 &&put_struct,
1371 &&put_unsafe,
1372 &&put_var_P,
1373 &&write_void,
1374 &&write_var_X,
1375 &&write_var_Y,
1376 &&write_val_X,
1377 &&write_val_Y,
1378 &&write_atom,
1379 &&write_list,
1380 &&write_struct,
1381 &&write_last_list,
1382 &&write_last_struct,
1383 &&write_local_X,
1384 &&write_local_Y,
1385 &&write_var_P,
1386 &&pop,
1387 &&jump,
1388 &&proceed,
1389 &&call,
1390 &&safe_call,
1391 &&safe_call_unary,
1392 &&safe_call_binary,
1393 &&only_1_clause,
1394 &&try_me,
1395 &&retry_me,
1396 &&trust_me,
1397 &&do_nothing,
1398 &&direct_safe_call,
1399 &&direct_safe_call_unary,
1400 &&direct_safe_call_binary,
1401 &&skip_while_var,
1402 &&wait_while_var,
1403 &&force_wait,
1404 &&write_call,
1405 &&is_call,
1406 &&equal_call,
1407 &&cut,
1408 &&commit,
1409 &&fail,
1410 &&save_b_X,
1411 &&save_b_Y,
1412 &&comit_b_X,
1413 &&comit_b_Y,
1414 &&save_appl_X,
1415 &&save_appl_Y,
1416 &&save_pair_X,
1417 &&save_pair_Y,
1418 &&either,
1419 &&orelse,
1420 &&orlast,
1421 &&p_atom,
1422 &&p_atomic,
1423 &&p_equal,
1424 &&p_integer,
1425 &&p_nonvar,
1426 &&p_number,
1427 &&p_var,
1428 &&p_db_ref,
1429 &&p_primitive,
1430 &&p_cut_by,
1431 &&p_succ,
1432 &&p_predc,
1433 &&p_plus,
1434 &&p_minus,
1435 &&p_times,
1436 &&p_div,
1437 &&p_dif,
1438 &&p_eq,
1439 &&p_arg,
1440 &&p_functor
1441 };
1442 #if Debug
1443 static int contador=1;
1444 #endif
1445 Cell code2start[]={_prepare_calls,1,0,_call_op,0,0};
1446
1447
1448 if ((long) initPred==2) { /* retry from call eam(goal) */
1449 goto fail;
1450 } else if ((long) initPred==1) { /* first time call eam(goal) */
1451 initPred=prepare_args_torun();
1452 }
1453 #if DIRECT_JUMP
1454 else if ((long) initPred==0) { /* first time call eam_am. Init TABLE_OPS */
1455 TABLE_OPS=(Cell *) OpAddress;
1456 return(FALSE);
1457 }
1458 #endif
1459 if (initPred==NULL || initPred->beamTable==NULL) return (FALSE);
1460
1461 #if DIRECT_JUMP
1462 code2start[0]=(Cell) OpAddress[_prepare_calls];
1463 code2start[3]=(Cell) OpAddress[_call_op];
1464 #endif
1465
1466 code2start[2]=(Cell) &code2start[5];
1467 code2start[4]=(Cell) initPred;
1468
1469 printf("[ EAM execution started to solve %s/%d ]\n",
1470 initPred->beamTable->name, initPred->beamTable->arity );
1471
1472 initialize_memory_areas();
1473
1474 beam_su=NULL;
1475 beam_OBX=NULL;
1476 beam_ABX=(struct AND_BOX *) request_memory(ANDBOX_SIZE);
1477 beam_ABX->parent=NULL;
1478 beam_ABX->nr_alternative=NULL;
1479 beam_ABX->nr_all_calls=0;
1480 beam_ABX->perms=NULL;
1481 beam_ABX->calls=NULL;
1482 beam_ABX->level=1;
1483 beam_ABX->externals=NULL;
1484 beam_ABX->suspended=NULL;
1485 beam_ABX->side_effects=0;
1486 beam_top=beam_ABX;
1487
1488 if (1) { int i; /* criar mais um nivel acima do top para o caso de haver variaveis na chamada */
1489 beam_ABX->nr_all_calls=1;
1490 beam_ABX->calls= (struct status_and *) request_memory(STATUS_AND_SIZE);
1491 beam_ABX->calls->locals=NULL;
1492 beam_ABX->calls->code=NULL;
1493 beam_ABX->calls->state=RUNNING;
1494 beam_ABX->calls->previous=NULL;
1495 beam_ABX->calls->next=NULL;
1496 beam_OBX= (struct OR_BOX *) request_memory(ORBOX_SIZE);
1497 beam_ABX->calls->call=beam_OBX;
1498 beam_OBX->nr_call=beam_ABX->calls;
1499 beam_OBX->parent=beam_ABX;
1500 beam_OBX->nr_all_alternatives=1;
1501 beam_OBX->eager_split=0;
1502
1503 beam_OBX->alternatives=(struct status_or *) request_memory(STATUS_OR_SIZE);
1504 beam_OBX->alternatives->previous=NULL;
1505 beam_OBX->alternatives->next=NULL;
1506 beam_OBX->alternatives->args=NULL;
1507 beam_OBX->alternatives->code=NULL;
1508 beam_OBX->alternatives->state=RUNNING;
1509
1510 beam_ABX=(struct AND_BOX *) request_memory(ANDBOX_SIZE);
1511 beam_OBX->alternatives->alternative=beam_ABX;
1512 beam_ABX->parent=beam_OBX;
1513 beam_ABX->nr_alternative=beam_OBX->alternatives;
1514 beam_ABX->nr_all_calls=0;
1515 beam_ABX->perms=NULL;
1516 beam_ABX->calls=NULL;
1517 beam_ABX->level=2;
1518 beam_ABX->externals=NULL;
1519 beam_ABX->suspended=NULL;
1520 beam_ABX->side_effects=WRITE;
1521
1522 for(i=1;i<=initPred->beamTable->arity;i++)
1523 add_vars_to_listperms(beam_ABX,(Cell *) beam_X[i]);
1524 }
1525
1526 beam_pc=code2start;
1527 execute_next();
1528
1529 while (1) {
1530
1531 exit_eam:
1532 #if Debug
1533 printf("%5d->(%3d) exit_eam ->",contador++, (int) *beam_pc);
1534 break_debug(contador);
1535 #endif
1536
1537 wake:
1538 #if Debug
1539 printf("%5d->Trying WAKE and_box on suspension \n",contador++);
1540 break_debug(contador);
1541 #endif
1542 if (verify_externals(beam_ABX)==0) goto fail_verify_externals;
1543 if (beam_ABX->externals==NULL) {
1544 beam_nr_call=beam_ABX->calls;
1545 if (beam_nr_alternative->state & END) {
1546 goto success;
1547 }
1548 beam_nr_alternative->state=RUNAGAIN;
1549 goto next_call;
1550 }
1551 beam_nr_alternative->state=SUSPEND;
1552 /* must clear all external assignments */
1553 limpa_trail(beam_ABX);
1554 /* goto top_tree; */
1555
1556 top_tree:
1557 #if Debug
1558 printf("%5d->I'm on top of the Tree (maybe exit or look for suspended alternatives) \n",contador++);
1559 break_debug(contador);
1560 break_top();
1561 #endif
1562
1563 #if GARBAGE_COLLECTOR
1564 if (HEAP_MEM_FULL()) garbage_collector();
1565 #endif
1566
1567 #if USE_LEFTMOST
1568 if (beam_su!=NULL) {
1569 beam_ABX=beam_su->and_box;
1570 beam_OBX=beam_ABX->parent;
1571 beam_nr_alternative=beam_ABX->nr_alternative;
1572 if (beam_nr_alternative->state & (WAKE)) goto wake;
1573 }
1574 beam_ABX=choose_leftmost();
1575 if (beam_ABX==NULL) { /* Must return to next_alternative in beam_OBX BECAUSE EAGER_SPLIT*/
1576 beam_nr_alternative=beam_ABX->nr_alternative;
1577 beam_ABX=beam_OBX->parent;
1578 goto next_alternative;
1579 }
1580 if (beam_ABX!=beam_top && beam_ABX->suspended!=NULL) {
1581 #else
1582 if (beam_su!=NULL) { /* There are suspended alternatives */
1583 beam_ABX=beam_su->and_box;
1584 #endif
1585
1586 #if !Fast_go
1587 if (beam_ABX==NULL || beam_ABX->parent==NULL || beam_ABX->parent->alternatives==NULL) abort_eam("Alternativa NULL NO TOP ?????");
1588 #endif
1589 beam_OBX=beam_ABX->parent;
1590 beam_nr_alternative=beam_ABX->nr_alternative;
1591
1592 if (beam_ABX->suspended->reason==VAR_SUSPENSION) {
1593 delfrom_suspensions_list(beam_ABX->suspended);
1594 beam_nr_call=beam_ABX->calls;
1595 goto next_call;
1596 }
1597 if (beam_ABX->suspended->reason!=NORMAL_SUSPENSION) {
1598 if (beam_ABX->calls->state==WAITING_TO_BE_FIRST ||
1599 (beam_ABX->calls->state & WAITING && is_leftmost(beam_ABX,0))) {
1600
1601 delfrom_suspensions_list(beam_ABX->suspended);
1602 beam_ABX->calls->state=READY;
1603 beam_nr_call=beam_ABX->calls;
1604 goto next_call;
1605 }
1606 #if !USE_LEFTMOST
1607 beam_su=beam_su->next;
1608 goto top_tree;
1609 #endif
1610 }
1611
1612 if (beam_OBX->nr_all_alternatives==1 && beam_ABX->level>beam_OBX->parent->level) {
1613 #if !Fast_go
1614 if (beam_OBX->parent->parent==NULL) abort_eam("Null no top_tree ");
1615 #endif
1616 goto unique_alternative;
1617 }
1618 if (beam_nr_alternative->state & (WAKE)) goto wake;
1619 if (beam_OBX->nr_all_alternatives>1) {
1620 #if Debug
1621 printf("%5d->Trying Fork in suspended and_box \n",contador++);
1622 break_debug(contador);
1623 #endif
1624 /* pickup the left most alternative instead */
1625 split:
1626 beam_OBX=beam_ABX->parent;
1627 #if USE_SPLIT
1628 do_forking_andbox(beam_ABX);
1629 #else
1630 abort_eam("ERROR: Split disable, cannot run non-deterministic programs...");
1631 #endif
1632 beam_OBX=beam_ABX->parent;
1633 beam_nr_alternative=beam_ABX->nr_alternative;
1634 goto unique_alternative;
1635 }
1636
1637 abort_eam("ERROR: exit on top, suspensions still available");
1638 }
1639 /* There is no suspension */
1640 give_solution_toyap();
1641 return (TRUE);
1642 exit_eam("\nExit on top, there is no more work to do... \n");
1643
1644 proceed:
1645 #if Debug
1646 printf("%5d->proceed... \n",contador++);
1647 #endif
1648
1649 if (beam_USE_SAME_ANDBOX!=NULL) { /* was only one alternative */
1650 beam_USE_SAME_ANDBOX=NULL;
1651 beam_nr_call=remove_call_from_andbox(beam_nr_call,beam_ABX);
1652 goto next_call;
1653 }
1654 if (beam_ABX->externals!=NULL) {
1655 beam_nr_alternative->state=SUSPEND_END;
1656 goto suspend;
1657 }
1658
1659 success:
1660 #if Debug
1661 printf("%5d->SUCCESS for call %p in level %d \n",contador++, beam_nr_call, beam_ABX->level );
1662 break_debug(contador);
1663 #endif
1664 /* FOUND SOLUTION -> ALL_SOLUTIONS */
1665 //if ((beam_ABX->side_effects & WRITE) && beam_OBX->nr_all_alternatives>1)
1666 if (beam_OBX->parent==beam_top) {
1667 give_solution_toyap();
1668 return (TRUE);
1669 goto fail;
1670 }
1671
1672 beam_ABX=beam_OBX->parent;
1673 beam_nr_call=beam_OBX->nr_call;
1674 del_orbox_and_sons(beam_OBX);
1675 beam_nr_call=remove_call_from_andbox(beam_nr_call,beam_ABX);
1676
1677 if (beam_ABX->externals!=NULL) {
1678 if (beam_ABX->nr_all_calls==0) {
1679 beam_nr_alternative->state=SUSPEND_END;
1680 } else beam_nr_alternative->state=SUSPEND;
1681 goto suspend;
1682 }
1683
1684 if (beam_ABX->nr_all_calls==0) {
1685 beam_OBX=beam_ABX->parent;
1686
1687 if (beam_OBX==NULL) {
1688 goto top_tree;
1689 }
1690 beam_nr_alternative=beam_ABX->nr_alternative;
1691 goto success;
1692 }
1693
1694 next_call:
1695 #if Debug
1696 printf("%5d->Searching for a next call in and_box... \n",contador++);
1697 break_debug(contador);
1698 #endif
1699
1700 #if GARBAGE_COLLECTOR
1701 if (HEAP_MEM_FULL()) {
1702 garbage_collector();
1703 }
1704 #endif
1705
1706 { register int nr;
1707 nr=beam_ABX->nr_all_calls;
1708
1709 if (beam_ABX->externals!=NULL && beam_ABX->side_effects<CUT) {
1710 if (nr==0) beam_nr_alternative->state=SUSPEND_END;
1711 else { /* if next call is a cut then execute it */
1712 beam_pc=beam_ABX->calls->code;
1713 #if Debug
1714 if (*beam_pc==_cut_op) {
1715 #else
1716 if (*beam_pc==(Cell) &&cut) {
1717 #endif
1718 beam_nr_call=beam_ABX->calls;
1719 execute_next();
1720 }
1721 beam_nr_alternative->state=SUSPEND;
1722 }
1723 goto suspend;
1724 }
1725 if (nr==0) {
1726 goto success;
1727 }
1728 #if !START_ON_NEXT
1729 beam_nr_call=beam_ABX->calls;
1730 #else
1731 /* if (beam_ABX->parent==beam_OBX) beam_nr_call=beam_ABX->calls; else beam_nr_call=beam_OBX->nr_call->next; */
1732 #endif
1733 while(beam_nr_call!=NULL) {
1734
1735 if (beam_nr_call->state & WAITING) {
1736 if (beam_nr_call->state==WAITING_TO_BE_LEFTMOST) {
1737 if (!is_leftmost(beam_ABX,beam_nr_call)) {
1738 beam_ABX->suspended=addto_suspensions_list(beam_ABX,LEFTMOST_SUSPENSION);
1739 beam_nr_call=NULL;
1740 break;
1741 }
1742 beam_nr_call->state=READY;
1743 }
1744
1745 if (beam_nr_call->state==WAITING_TO_BE_LEFTMOST_PARENT) {
1746 if (!is_leftmost(beam_ABX->parent->parent,beam_ABX->parent->nr_call)) {
1747 beam_ABX->suspended=addto_suspensions_list(beam_ABX,LEFTMOST_SUSPENSION);
1748 beam_nr_call=NULL;
1749 break;
1750 }
1751 beam_nr_call->state=READY;
1752 }
1753
1754 if (beam_nr_call->state==WAITING_TO_BE_FIRST) {
1755 if (beam_nr_call->previous==NULL) {
1756 #if Debug
1757 printf("I can stop Waiting on call %p\n", beam_nr_call);
1758 #endif
1759 beam_nr_call=remove_call_from_andbox(beam_nr_call,beam_ABX);
1760 continue;
1761 }
1762 #if Debug
1763 printf("Force Waiting on call %p\n", beam_nr_call);
1764 #endif
1765 beam_nr_call=NULL;
1766 break;
1767 }
1768 }
1769 if (beam_nr_call->state==READY) {
1770 beam_varlocals=beam_nr_call->locals;
1771 beam_pc=beam_nr_call->code;
1772 execute_next();
1773 }
1774 beam_nr_call=beam_nr_call->next;
1775 }
1776 beam_OBX=beam_ABX->parent;
1777 /* In case (beam_nr_call==nr) */
1778
1779 beam_nr_alternative=beam_ABX->nr_alternative;
1780 if (beam_ABX->externals!=NULL) goto suspend;
1781
1782 if (beam_nr_alternative!=NULL) beam_nr_alternative=beam_nr_alternative->next;
1783 goto next_alternative;
1784 }
1785
1786 fail_body:
1787 fail_head:
1788 fail:
1789 #if Debug
1790 printf("%5d->fail... \n",contador++);
1791 break_debug(contador);
1792 #endif
1793
1794 fail_verify_externals:
1795 if (beam_ABX->externals!=NULL) {
1796 limpa_trail(beam_ABX);
1797 }
1798
1799 beam_OBX=beam_ABX->parent;
1800 beam_nr_alternative=beam_ABX->nr_alternative;
1801 if (beam_OBX==NULL) {
1802 if (beam_ABX==beam_top) return(FALSE);
1803 abort_eam("ERROR -> beam_ABX->parent = NULL (em fail_verify_externals) ?????\n");
1804 }
1805
1806 beam_OBX->nr_all_alternatives=beam_OBX->nr_all_alternatives-1;
1807 if (beam_nr_alternative->next!=NULL) beam_nr_alternative->next->previous=beam_nr_alternative->previous;
1808 if (beam_nr_alternative->previous!=NULL) beam_nr_alternative->previous->next=beam_nr_alternative->next;
1809 else beam_OBX->alternatives=beam_nr_alternative->next; /* apaguei o primeiro da lista */
1810 { register struct status_or *i;
1811 i=beam_nr_alternative;
1812 beam_nr_alternative=beam_nr_alternative->next;
1813 free_memory((Cell *) i,STATUS_OR_SIZE);
1814 del_andbox_and_sons(beam_ABX);
1815 } /* verificar se existe ainda alguma alternativa viavel nesta or_box */
1816
1817 next_alternative:
1818 #if Debug
1819 printf("%5d->Searching for a next alternative in or_box... \n",contador++);
1820 break_debug(contador);
1821 #endif
1822
1823 #if GARBAGE_COLLECTOR
1824 if (HEAP_MEM_FULL()) garbage_collector();
1825 #endif
1826
1827 if (beam_OBX==NULL) {
1828 #if !Fast_go
1829 if (beam_ABX!=beam_top) abort_eam("Erro no next_Alternative");
1830 #endif
1831 goto top_tree;
1832 }
1833
1834 if (beam_OBX->nr_all_alternatives==0) {
1835 beam_ABX=beam_OBX->parent;
1836 goto fail;
1837 }
1838 if (beam_OBX->nr_all_alternatives==1 && beam_ABX->level>beam_OBX->parent->level) {
1839 beam_nr_alternative=beam_OBX->alternatives;
1840 beam_ABX=beam_OBX->alternatives->alternative;
1841 if (beam_ABX==NULL) {
1842 beam_pc=beam_OBX->alternatives->code;
1843 execute_next();
1844 }
1845 if (beam_OBX->parent->parent==NULL) goto top_tree;
1846 goto unique_alternative;
1847 }
1848 #if !START_ON_NEXT
1849 beam_nr_alternative=beam_OBX->alternatives;
1850 #else
1851 /* if (beam_OBX->parent==beam_ABX) beam_nr_alternative=beam_OBX->alternatives;
1852 else { if (beam_nr_alternative!=NULL) beam_nr_alternative=beam_nr_alternative->next; } */
1853 #endif
1854 while(beam_nr_alternative!=NULL) {
1855 if (beam_nr_alternative->state & (WAKE) ) {
1856 beam_ABX=beam_nr_alternative->alternative;
1857 goto wake;
1858 }
1859 if (beam_nr_alternative->state==READY) {
1860 beam_pc=beam_nr_alternative->code;
1861 execute_next();
1862 }
1863 beam_nr_alternative=beam_nr_alternative->next;
1864 }
1865
1866 /* beam_nr_alternative==NULL -> No more alternatives */
1867 beam_ABX=beam_OBX->parent;
1868 beam_nr_call=beam_OBX->nr_call->next;
1869 goto next_call;
1870
1871 unique_alternative:
1872 #if Debug
1873 printf("%5d->Unique alternative, Does Promotion on and-box\n",contador++);
1874 break_debug(contador);
1875 #endif
1876
1877 #if GARBAGE_COLLECTOR
1878 if (HEAP_MEM_FULL() ) garbage_collector();
1879 #endif
1880 if (beam_OBX->parent->parent==NULL) {
1881 goto top_tree;
1882 }
1883
1884 { int nr_a;
1885 struct AND_BOX *a;
1886 if (beam_ABX->side_effects >= CUT) {
1887 /* Cut -> Avoid doing the Promotion */
1888 inc_level(beam_ABX,beam_OBX->parent->level-beam_ABX->level);
1889
1890 delfrom_suspensions_list(beam_ABX->suspended);
1891 if (verify_externals(beam_ABX)==0) goto fail_verify_externals;
1892 beam_nr_alternative=beam_ABX->nr_alternative;
1893 if (beam_ABX->externals==NULL) {
1894 beam_nr_call=beam_ABX->calls;
1895 goto next_call;
1896 }
1897 beam_ABX->suspended=addto_suspensions_list(beam_ABX,NORMAL_SUSPENSION);
1898 beam_nr_alternative->state=SUSPEND;
1899 beam_nr_alternative=beam_nr_alternative->next;
1900 goto next_alternative;
1901 }
1902 a=beam_ABX;
1903 beam_ABX=beam_OBX->parent;
1904 nr_a=a->nr_all_calls;
1905 beam_nr_call=beam_OBX->nr_call;
1906 beam_ABX->side_effects+=a->side_effects;
1907 if (nr_a==0) { /* Means SUSPENDED ON END */
1908 beam_nr_call->call=NULL;
1909 beam_nr_call->state=SUCCESS;
1910 beam_nr_call=remove_call_from_andbox(beam_nr_call,beam_ABX);
1911 } else { /* IF nr_all_calls==1 can be optimized ????? */
1912 if (nr_a==1) {
1913
1914 if (a->calls->call!=NULL) {
1915 a->calls->call->nr_call=beam_nr_call;
1916 a->calls->call->parent=beam_ABX;
1917 }
1918 beam_nr_call->call=a->calls->call;
1919 beam_nr_call->locals=a->calls->locals;
1920 beam_nr_call->code=a->calls->code;
1921 beam_nr_call->state=a->calls->state;
1922 free_memory((Cell *) a->calls,STATUS_AND_SIZE);
1923 } else {
1924 struct status_and *first, *last;
1925 int nr;
1926
1927 nr=beam_ABX->nr_all_calls;
1928
1929 first=a->calls;
1930 last=a->calls;
1931 while(1) {
1932 if (last->call!=NULL) {
1933 last->call->parent=beam_ABX;
1934 }
1935 if (last->next==NULL) break;
1936 last=last->next;
1937 }
1938 last->next=beam_nr_call->next;
1939 if (beam_nr_call->next!=NULL) beam_nr_call->next->previous=last;
1940 first->previous=beam_nr_call->previous;
1941 if (beam_nr_call->previous!=NULL) beam_nr_call->previous->next=first;
1942 else beam_ABX->calls=first; /* nr_call era o primeiro */
1943 free_memory((Cell *) beam_nr_call,STATUS_AND_SIZE);
1944 beam_nr_call=first;
1945 beam_ABX->nr_all_calls=nr+nr_a-1;
1946 }
1947 /* Set local vars from a to point to new and_box beam_ABX */
1948 }
1949 move_perm_vars(a,beam_ABX);
1950
1951 /* change local vars suspensions to point to new andbox */
1952 { struct EXTERNAL_VAR *end,*e;
1953 e=a->externals;
1954 end=NULL;
1955 while(e!=NULL) {
1956 struct SUSPENSIONS_VAR *s;
1957 s=e->var->suspensions;
1958 while(s!=NULL) {
1959 if (s->and_box==a) { s->and_box=beam_ABX; break; }
1960 s=s->next;
1961 }
1962 end=e;
1963 e=e->next;
1964 }
1965 /* Clear bindings made on externals so that we are able to
1966 run the verify externals */
1967 e=beam_ABX->externals;
1968 while(e!=NULL) {
1969 struct PERM_VAR *v;
1970 v=e->var;
1971 *((Cell *) v)=(Cell) v;
1972 e=e->next;
1973 }
1974 if (end!=NULL) {
1975 end->next=beam_ABX->externals;
1976 beam_ABX->externals=a->externals;
1977 }
1978
1979 delfrom_suspensions_list(a->suspended); /* remove suspensions */
1980 free_memory((Cell *) a,ANDBOX_SIZE);
1981 free_memory((Cell *) beam_OBX->alternatives,STATUS_OR_SIZE);
1982 free_memory((Cell *) beam_OBX,ORBOX_SIZE);
1983
1984 beam_OBX=beam_ABX->parent;
1985 if (verify_externals(beam_ABX)==0) goto fail_verify_externals;
1986 }
1987
1988 beam_nr_alternative=beam_ABX->nr_alternative;
1989 if (beam_ABX->externals==NULL) {
1990 beam_nr_call=beam_ABX->calls;
1991 goto next_call;
1992 }
1993 beam_ABX->suspended=addto_suspensions_list(beam_ABX,NORMAL_SUSPENSION);
1994 beam_nr_alternative->state=SUSPEND;
1995 beam_nr_alternative=beam_nr_alternative->next;
1996 goto next_alternative;
1997 }
1998
1999 abort_eam("cheguei aqui para tentar executar o prepare_tries antigo...\n");
2000
2001 prepare_tries:
2002 #if Debug
2003 printf("%5d->prepare_tries for %d clauses with arity=%d \n",contador++,(int) arg1,(int) arg2);
2004 break_debug(contador);
2005 #endif
2006 if (!arg1) goto fail;
2007 { register int nr;
2008 nr=arg1;
2009
2010 if (nr==1 && beam_ABX->parent!=NULL) {
2011 beam_ES=0;
2012 beam_nr_call->state=RUNNING;
2013 beam_pc+=3;
2014 /* execute_next(); */
2015 goto only_1_clause;
2016 }
2017
2018 beam_OBX=(struct OR_BOX *) request_memory(ORBOX_SIZE);
2019 beam_nr_call->call=beam_OBX;
2020 beam_nr_call->state=RUNNING;
2021 beam_OBX->nr_call=beam_nr_call;
2022 beam_OBX->parent=beam_ABX;
2023 beam_OBX->eager_split=beam_ES;
2024 beam_ES=0;
2025 beam_OBX->nr_all_alternatives=nr;
2026
2027 { register int i;
2028 register struct status_or *p=NULL;
2029 register Cell *a;
2030
2031 if (nr>1) a=save_arguments(arg2); else a=NULL;
2032 beam_pc+=3;
2033 for(i=0;i<nr;i++) {
2034 beam_nr_alternative=(struct status_or *) request_memory(STATUS_OR_SIZE);
2035 if (i==0) beam_OBX->alternatives=beam_nr_alternative; else p->next=beam_nr_alternative;
2036 beam_nr_alternative->previous=p;
2037 p=beam_nr_alternative;
2038 beam_nr_alternative->alternative=NULL;
2039 beam_nr_alternative->code=beam_pc;
2040 beam_nr_alternative->state=READY;
2041 beam_nr_alternative->args=a;
2042 beam_pc+=5;
2043 }
2044 beam_nr_alternative->next=NULL;
2045 }
2046 }
2047 beam_nr_alternative=beam_OBX->alternatives;
2048 /* goto next_alternative; */
2049 beam_pc=beam_nr_alternative->code;
2050 goto try_me;
2051 execute_next();
2052
2053 /* explore_alternative */
2054 trust_me:
2055 get_arguments(arg2,beam_nr_alternative->args);
2056 remove_memory_arguments(beam_nr_alternative->args);
2057 goto try_me;
2058 retry_me:
2059 get_arguments(arg2,beam_nr_alternative->args);
2060 try_me:
2061 beam_nr_alternative->args=NULL;
2062 #if Debug
2063 printf("%5d->Create AND_BOX for the %dth clause of predicate %s/%d (Yvars=%d) \n",contador++,(int) arg4,((struct Clauses *)arg1)->predi->name,(int) arg2,(int) arg3);
2064 break_debug(contador);
2065 #endif
2066 if (beam_OBX->nr_all_alternatives>1 || beam_OBX->parent->parent==NULL) {
2067
2068 beam_USE_SAME_ANDBOX=NULL;
2069 beam_ABX=(struct AND_BOX *)request_memory(ANDBOX_SIZE);
2070 beam_nr_alternative->alternative=beam_ABX;
2071 beam_nr_alternative->state=RUNNING;
2072
2073 beam_ABX->nr_alternative=beam_nr_alternative;
2074 beam_ABX->level=beam_OBX->parent->level+1;
2075 beam_ABX->parent=beam_OBX;
2076 beam_ABX->externals=NULL;
2077 beam_ABX->suspended=NULL;
2078 beam_ABX->perms=NULL;
2079 beam_ABX->calls=NULL;
2080 beam_ABX->nr_all_calls=0;
2081 beam_ABX->side_effects=((struct Clauses *)arg1)->side_effects;
2082 /* continue on middle of only_1_clause code */
2083 } else {
2084 beam_nr_call=beam_OBX->nr_call;
2085 beam_ABX=beam_OBX->parent;
2086 del_orbox_and_sons(beam_OBX);
2087 beam_nr_call->call=NULL;
2088 /* continue to only 1 clause */
2089
2090 only_1_clause:
2091 #if Debug
2092 printf("Only 1 Clause -> Use the same AND_BOX for the %dth clause of predicate %s/%d (Yvars=%d) \n",(int) arg4,((struct Clauses *)arg1)->predi->name,(int) arg2,(int) arg3);
2093 #endif
2094
2095 if (((struct Clauses *)arg1)->side_effects >= CUT) {
2096 /* printf("Must create or-box still the same ?????\n"); MUST SEE THIS CASE */
2097 }
2098 beam_USE_SAME_ANDBOX=beam_nr_call;
2099 beam_nr_alternative=beam_ABX->nr_alternative;
2100 beam_OBX=beam_ABX->parent;
2101 }
2102
2103 if (arg3) {
2104 register int nr_locals;
2105 nr_locals=arg3;
2106 /* nr_locals=((struct Clauses *)arg1)->nr_vars; */
2107 beam_varlocals=request_memory_locals(nr_locals);
2108 // add_to_list_locals(beam_varlocals,beam_ABX);
2109 } else {
2110 beam_varlocals=NULL;
2111 }
2112 beam_pc=((struct Clauses *)arg1)->code+5;
2113 execute_next();
2114
2115 prepare_calls:
2116 #if Debug
2117 printf("%5d->prepare_calls %d\n",contador++,(int) arg1);
2118 break_debug(contador);
2119 #endif
2120 if (beam_USE_SAME_ANDBOX!=NULL) { /* only one alternative */
2121 register int nr;
2122
2123 nr=(int) arg1;
2124 beam_pc+=2;
2125 if (nr) {
2126 beam_nr_call=beam_USE_SAME_ANDBOX;
2127 if (nr==1) { /* ONLY ONE CALL , CHANGE DIRECTLY */
2128 beam_nr_call->call=NULL;
2129 beam_nr_call->code=beam_pc+1;
2130 beam_nr_call->locals=beam_varlocals;
2131 beam_nr_call->state=READY;
2132 } else {
2133 struct status_and *calls,*first=NULL,*last=NULL;
2134 int i,nr2;
2135
2136 nr2=beam_ABX->nr_all_calls;
2137
2138 for(i=0;i<nr;i++) {
2139 calls=(struct status_and *) request_memory(STATUS_AND_SIZE);
2140 if (first==NULL) first=calls;
2141 if (last!=NULL) last->next=calls;
2142 calls->previous=last;
2143 calls->call=NULL;
2144 calls->code=beam_pc+1;
2145 calls->locals=beam_varlocals;
2146 calls->state=READY;
2147 beam_pc=(Cell *) *beam_pc;
2148 last=calls;
2149 }
2150
2151 last->next=beam_nr_call->next;
2152 if (beam_nr_call->next!=NULL) beam_nr_call->next->previous=last;
2153 first->previous=beam_nr_call->previous;
2154 if (beam_nr_call->previous!=NULL) beam_nr_call->previous->next=first;
2155 else beam_ABX->calls=first; /* nr_call era o primeiro */
2156
2157 free_memory((Cell *) beam_nr_call,STATUS_AND_SIZE);
2158 beam_nr_call=first;
2159 beam_ABX->nr_all_calls=nr+nr2-1;
2160 }
2161 } else {
2162 beam_nr_call->call=NULL;
2163 }
2164 } else
2165 { /* there where more than one alternative */
2166 register int nr;
2167 nr=(int) arg1;
2168 beam_pc+=2;
2169 beam_ABX->nr_all_calls=nr;
2170 if (nr) {
2171 struct status_and *calls, *first=NULL, *last=NULL;
2172 register int i;
2173
2174 for(i=0;i<nr;i++) {
2175 calls=(struct status_and *) request_memory(STATUS_AND_SIZE);
2176 if (first==NULL) first=calls;
2177 if (last!=NULL) last->next=calls;
2178 calls->previous=last;
2179 calls->call=NULL;
2180 calls->code=beam_pc+1;
2181 calls->locals=beam_varlocals;
2182 calls->state=READY;
2183 beam_pc=(Cell *) *beam_pc;
2184 last=calls;
2185 }
2186 last->next=NULL;
2187 beam_ABX->calls=first;
2188
2189 } else beam_ABX->calls=NULL;
2190 beam_nr_call=beam_ABX->calls;
2191 }
2192 /* goto scheduler;*/
2193
2194 scheduler:
2195 #if Debug
2196 printf("%5d->Scheduler... \n",contador++);
2197 break_debug(contador);
2198 #endif
2199 #if Debug_Dump_State
2200 dump_eam_state();
2201 #endif
2202 /* Have to decide if I go up or continue on same level */
2203 /* If I go up the I have to suspend the and_box,
2204 else I can continue to the next clause (1st) of the and_box
2205 Another Alternative is to pick up a SUSPEND and_box */
2206 /* for the meantime I Will always suspend unless there is a cut */
2207
2208 if (beam_ABX->externals==NULL || beam_ABX->side_effects>=CUT) {
2209 beam_pc=beam_nr_call->code;
2210 execute_next();
2211 }
2212 beam_nr_alternative->state=SUSPEND;
2213 /* goto suspend; */
2214
2215 suspend:
2216 #if Debug
2217 printf("%5d->SUSPEND on alternative %p\n",contador++,beam_nr_alternative);
2218 break_debug(contador);
2219 #endif
2220 beam_OBX=beam_ABX->parent;
2221 { struct EXTERNAL_VAR *e;
2222 struct PERM_VAR *v;
2223 struct SUSPENSIONS_VAR *s;
2224
2225 beam_ABX->suspended=addto_suspensions_list(beam_ABX,NORMAL_SUSPENSION);
2226 e=beam_ABX->externals;
2227 while(e!=NULL) {
2228 v=e->var;
2229 *((Cell *) v)=(Cell) v;
2230 if (v->suspensions==NULL || v->suspensions->and_box!=beam_ABX) {
2231 /* se a and_box ja esta na lista nao adiciona */
2232 s=(struct SUSPENSIONS_VAR *) request_memory(SUSPENSIONS_VAR_SIZE);
2233 s->and_box=beam_ABX;
2234 s->next=v->suspensions;
2235 v->suspensions=s;
2236 }
2237 e=e->next;
2238 }
2239 }
2240 if (beam_OBX->eager_split) goto split;
2241
2242 beam_nr_alternative=beam_nr_alternative->next;
2243 goto next_alternative;
2244
2245
2246 call_yap:
2247 /* Must create term to call */
2248 /* YAP_RunGoal(t_goal); */
2249
2250 if (!Yap_execute_goal(beam_X[1],0,CurrentModule)) goto success;
2251 else goto fail;
2252
2253 call:
2254 #if Debug
2255 printf("%5d->call %s/%d \n",contador++,((PredEntry *) arg1)->beamTable->name,(int) ((PredEntry *) arg1)->beamTable->arity);
2256 break_debug(contador);
2257 #endif
2258 beam_ES=((PredEntry *) arg1)->beamTable->eager_split;
2259
2260 /* CUIDADO : vou tentar libertar a memoria caso seja o ultimo call */
2261 #if DIRECT_JUMP
2262 if ((void *) arg3==&&exit_eam) /* Estou no ultimo call deste predicado */
2263 #else
2264 if (arg3==_exit_eam) /* Estou no ultimo call deste predicado */
2265 #endif
2266 {
2267 if (beam_ABX->nr_all_calls==1) {
2268 free_memory_locals(beam_nr_call->locals);
2269 } else {
2270 struct status_and *calls;
2271 calls=beam_ABX->calls;
2272 while(calls!=beam_nr_call) {
2273 if (calls->locals==beam_nr_call->locals) break;
2274 calls=calls->next;
2275 }
2276 if (calls==beam_nr_call) {
2277 free_memory_locals(beam_nr_call->locals);
2278 }
2279 }
2280 }
2281 beam_nr_call->locals=NULL;
2282 bpEntry=(PredEntry *) arg1;
2283 beam_ALTERNATIVES=beam_H;
2284 Yap_absmi(-9000);
2285 {
2286 int NR_INDEXED;
2287 NR_INDEXED=beam_ALTERNATIVES-beam_H;
2288 #if Debug
2289 printf("Back from yap-index with %d alternativas\n",NR_INDEXED);
2290 #endif
2291 if (NR_INDEXED==0) goto fail;
2292 if (NR_INDEXED==1 && beam_ABX->parent!=NULL) {
2293 struct Clauses *clause=(struct Clauses *) *(beam_H);
2294 beam_ES=0;
2295 beam_nr_call->state=RUNNING;
2296
2297 #if Debug
2298 printf("Only 1 Alternative\n");
2299 #endif
2300 if (clause->side_effects >= CUT) {
2301 /* printf("Must create or-box still the same ?????\n"); RSLOPES: MUST SEE THIS CASE */
2302 }
2303
2304 beam_USE_SAME_ANDBOX=beam_nr_call;
2305 beam_nr_alternative=beam_ABX->nr_alternative;
2306 beam_OBX=beam_ABX->parent;
2307
2308 if (clause->nr_vars) {
2309 register int nr_locals;
2310 nr_locals=clause->nr_vars;
2311 beam_varlocals=request_memory_locals(nr_locals);
2312 // add_to_list_locals(beam_varlocals,beam_ABX);
2313 } else {
2314 beam_varlocals=NULL;
2315 }
2316 beam_pc=clause->code+5;
2317 execute_next();
2318 } else {
2319 int i, arity;
2320 struct status_or *p=NULL;
2321 Cell *a;
2322 arity=((PredEntry *) arg1)->beamTable->arity;
2323
2324 beam_OBX=(struct OR_BOX *) request_memory(ORBOX_SIZE);
2325 beam_nr_call->call=beam_OBX;
2326 beam_nr_call->state=RUNNING;
2327 beam_OBX->nr_call=beam_nr_call;
2328 beam_OBX->parent=beam_ABX;
2329 beam_OBX->eager_split=beam_ES;
2330 beam_ES=0;
2331 beam_OBX->nr_all_alternatives=NR_INDEXED;
2332
2333 if (NR_INDEXED>1) a=save_arguments(arity); else a=NULL;
2334 for(i=0;i<NR_INDEXED;i++) {
2335 beam_nr_alternative=(struct status_or *) request_memory(STATUS_OR_SIZE);
2336 if (i==0) beam_OBX->alternatives=beam_nr_alternative; else p->next=beam_nr_alternative;
2337 beam_nr_alternative->previous=p;
2338 p=beam_nr_alternative;
2339 beam_nr_alternative->alternative=NULL;
2340 beam_pc=((struct Clauses *) beam_H[i])->code;
2341
2342 #if DIRECT_JUMP
2343 if (i==0) {
2344 if (NR_INDEXED==1) *beam_pc=(Cell) &&only_1_clause;
2345 else *beam_pc=(Cell) &&try_me;
2346 } else if (i==NR_INDEXED-1) *beam_pc=(Cell) &&trust_me;
2347 else *beam_pc=(Cell) &&retry_me;
2348 #else
2349 if (i==0) {
2350 if (NR_INDEXED==1) *beam_pc=_only_1_clause_op;
2351 else *beam_pc=_try_me_op;
2352 } else if (i==NR_INDEXED-1) *beam_pc=_trust_me_op;
2353 else *beam_pc=_retry_me_op;
2354 #endif
2355 arg2=arity;
2356 arg1=beam_H[i];
2357 arg3=((struct Clauses *) beam_H[i])->nr_vars;
2358 arg4=i;
2359 beam_nr_alternative->code=beam_pc;
2360 beam_nr_alternative->state=READY;
2361 beam_nr_alternative->args=a;
2362 }
2363 beam_nr_alternative->next=NULL;
2364
2365 beam_nr_alternative=beam_OBX->alternatives;
2366 /* goto next_alternative; */
2367 beam_pc=beam_nr_alternative->code;
2368 execute_next();
2369
2370 }
2371 }
2372 /* goto prepare_tries; */
2373
2374 safe_call:
2375 #if Debug
2376 printf("%5d->safe_call 0x%lX X1=%d (0x%lX) ,X2=%d (0x%lX) \n",contador++,(unsigned long) arg1,(int) beam_X[1],(unsigned long) beam_X[1],(int) beam_X[2],(unsigned long) beam_X[2]);
2377 break_debug(contador);
2378 #endif
2379 beam_S=(Cell *) arg1;
2380 beam_S=(Cell *) (* ((int long (*)(void)) beam_S))();
2381 if (!beam_S) goto fail_body;
2382
2383 /* we didn't get to created a or_box */
2384 beam_nr_call=remove_call_from_andbox(beam_nr_call,beam_ABX);
2385 beam_OBX=beam_ABX->parent;
2386 goto next_call;
2387
2388 safe_call_unary:
2389 #if Debug
2390 printf("%5d->safe_call_unary 0x%lX X1=%d (0x%lX) ,X2=%d (0x%lX) \n",contador++,(unsigned long) arg1,(int) beam_X[1],(unsigned long) beam_X[1],(int) beam_X[2],(unsigned long) beam_X[2]);
2391 break_debug(contador);
2392 #endif
2393 beam_S=(Cell *) arg1;
2394 beam_S=(Cell *) (* ((int long (*)(Term)) beam_S))(deref(beam_X[1]));
2395 if (!beam_S) goto fail_body;
2396
2397 /* we didn't get to created a or_box */
2398 beam_nr_call=remove_call_from_andbox(beam_nr_call,beam_ABX);
2399 beam_OBX=beam_ABX->parent;
2400 goto next_call;
2401
2402 safe_call_binary:
2403 #if Debug
2404 printf("%5d->safe_call_binary 0x%lX X1=%d (0x%lX) ,X2=%d (0x%lX) \n",contador++,(unsigned long) arg1,(int) beam_X[1],(unsigned long) beam_X[1],(int) beam_X[2],(unsigned long) beam_X[2]);
2405 break_debug(contador);
2406 #endif
2407 beam_S=(Cell *) arg1;
2408 beam_S=(Cell *) (* ((int long (*)(Term, Term)) beam_S))(deref(beam_X[1]),deref(beam_X[2]));
2409 if (!beam_S) goto fail_body;
2410
2411 /* we didn't get to created a or_box */
2412 beam_nr_call=remove_call_from_andbox(beam_nr_call,beam_ABX);
2413 beam_OBX=beam_ABX->parent;
2414 goto next_call;
2415
2416
2417 direct_safe_call:
2418 #if Debug
2419 printf("%5d->direct_safe_call %p X1=%d,X2=%d \n",contador++,(void *) arg1,(int) beam_X[1],(int) beam_X[2]);
2420 break_debug(contador);
2421 #endif
2422 beam_S=(Cell *) arg1;
2423 beam_S=(Cell *) (* ((int long (*)(void)) beam_S))();
2424 /* beam_S=(Cell *) (* ((int long (*)(Term,Term)) beam_S))(beam_X[1],beam_X[2]); */
2425 if (!beam_S) goto fail_head;
2426 beam_pc+=2;
2427 execute_next();
2428
2429 direct_safe_call_unary:
2430 #if Debug
2431 printf("%5d->direct_safe_call_unary %p X1=%d,X2=%d \n",contador++,(void *) arg1,(int) beam_X[1],(int) beam_X[2]);
2432 break_debug(contador);
2433 #endif
2434 beam_S=(Cell *) arg1;
2435 beam_S=(Cell *) (* ((int long (*)(Term)) beam_S))(deref(beam_X[1]));
2436 if (!beam_S) goto fail_head;
2437 beam_pc+=2;
2438 execute_next();
2439
2440 direct_safe_call_binary:
2441 #if Debug
2442 printf("%5d->direct_safe_call_binary %p X1=%d,X2=%d \n",contador++,(void *) arg1,(int) beam_X[1],(int) beam_X[2]);
2443 break_debug(contador);
2444 #endif
2445 beam_S=(Cell *) arg1;
2446 beam_S=(Cell *) (* ((int long (*)(Term,Term)) beam_S))(deref(beam_X[1]),deref(beam_X[2]));
2447 if (!beam_S) goto fail_head;
2448 beam_pc+=2;
2449 execute_next();
2450
2451 skip_while_var:
2452 #if Debug
2453 printf("%5d->Skip_while_var on call %p\n",contador++, beam_nr_call);
2454 break_debug(contador);
2455 #endif
2456 if (exists_var_in((Cell *) beam_X[1])) {
2457 beam_ABX->suspended=addto_suspensions_list(beam_ABX,VAR_SUSPENSION);
2458 beam_nr_call=beam_nr_call->next;
2459 goto next_call;
2460 }
2461 beam_pc+=1;
2462 execute_next();
2463
2464 wait_while_var:
2465 #if Debug
2466 printf("%5d->Wait_while_var on call %p\n",contador++, beam_nr_call);
2467 break_debug(contador);
2468 #endif
2469 if (exists_var_in((Cell *) beam_X[1])) {
2470 beam_ABX->suspended=addto_suspensions_list(beam_ABX,VAR_SUSPENSION);
2471 beam_OBX=beam_ABX->parent;
2472 beam_nr_alternative=beam_ABX->nr_alternative->next;
2473 goto next_alternative;
2474 }
2475 beam_pc+=1;
2476 execute_next();
2477
2478 force_wait:
2479 #if Debug
2480 printf("%5d->Force Waiting on call %p\n",contador++, beam_nr_call);
2481 break_debug(contador);
2482 #endif
2483 /* we didn't get to created a or_box */
2484
2485 beam_OBX=beam_ABX->parent;
2486 if (beam_nr_call->previous!=NULL) {
2487 beam_nr_call->call=NULL;
2488 beam_nr_call->state=WAITING_TO_BE_FIRST;
2489 beam_ABX->suspended=addto_suspensions_list(beam_ABX,WAIT_SUSPENSION);
2490 beam_nr_alternative=beam_ABX->nr_alternative->next;
2491 goto next_alternative;
2492 }
2493 beam_nr_call=remove_call_from_andbox(beam_nr_call,beam_ABX);
2494 goto next_call;
2495
2496 write_call:
2497 #if Debug
2498 printf("%5d->write_call\n",contador++);
2499 break_debug(contador);
2500 #endif
2501 #if USE_LEFTMOST
2502 if (!is_leftmost(beam_ABX,beam_nr_call)) {
2503 #if Debug
2504 printf("Force Waiting Before write_call\n");
2505 #endif
2506 beam_nr_call->call=NULL;
2507 beam_nr_call->state=WAITING_TO_BE_LEFTMOST;
2508 beam_ABX->suspended=addto_suspensions_list(beam_ABX,LEFTMOST_SUSPENSION);
2509 goto top_tree;
2510 }
2511 #endif
2512
2513 #ifdef DEBUG
2514 Yap_plwrite ((Term) beam_X[1], Yap_DebugPutc, 0, 1200);
2515 #else
2516 extern int beam_write (void);
2517 beam_write();
2518 #endif
2519 beam_nr_call=remove_call_from_andbox(beam_nr_call,beam_ABX);
2520 beam_ABX->side_effects=beam_ABX->side_effects | WRITE;
2521 beam_OBX=beam_ABX->parent;
2522 goto next_call;
2523
2524 is_call:
2525 #if Debug
2526 printf("%5d->is_call\n",contador++);
2527 break_debug(contador);
2528 #endif
2529 {
2530 Cell *_DR;
2531 /* BEAM_is is declared on C/eval.c */
2532 _DR=(Cell *) BEAM_is();
2533 if (_DR==NULL) { /* erro no Eval */
2534 beam_top=NULL;
2535 return (FALSE);
2536 }
2537 if (!Unify((Cell *) beam_X[1],_DR)) goto fail_body;
2538 }
2539 beam_nr_call=remove_call_from_andbox(beam_nr_call,beam_ABX);
2540 beam_OBX=beam_ABX->parent;
2541
2542 goto next_call;
2543
2544 equal_call:
2545 #if Debug
2546 printf("%5d->equal_call\n",contador++);
2547 break_debug(contador);
2548 #endif
2549 beam_nr_call=remove_call_from_andbox(beam_nr_call,beam_ABX);
2550 if (beam_ABX->externals!=NULL) {
2551 if (beam_ABX->nr_all_calls==0) {
2552 beam_nr_alternative->state=SUSPEND_END;
2553 } else beam_nr_alternative->state=SUSPEND;
2554 goto suspend;
2555 }
2556
2557 goto next_call;
2558
2559
2560 pop:
2561 #if Debug
2562 printf("%5d->pop %d \n",contador++,(int) arg1);
2563 break_debug(contador);
2564 #endif
2565 if (arg1>1) {
2566 beam_sp+=arg1>>2;
2567 }
2568 pop_mode_and_sreg();
2569 #if Debug
2570 if (beam_Mode==READ) printf("Continues in READ mode\n");
2571 else printf("Continues in WRITE mode\n");
2572 #endif
2573 beam_pc+=2;
2574 execute_next();
2575
2576 do_nothing:
2577 #if Debug
2578 printf("%5d->do_nothing \n",contador++);
2579 break_debug(contador);
2580 #endif
2581 beam_pc++;
2582 execute_next();
2583
2584
2585 get_var_X:
2586 #if Debug
2587 printf("%5d->get_var_X X%d=X%d \n",contador++,(int) arg2,(int) arg1);
2588 break_debug(contador);
2589
2590 #endif
2591 beam_X[arg2]=beam_X[arg1];
2592 beam_pc+=3;
2593 execute_next();
2594
2595 get_var_Y:
2596 #if Debug
2597 printf("%5d->get_var_Y Y%d=X%d \n",contador++,(int) arg2,(int) arg1);
2598 break_debug(contador);
2599 #endif
2600 beam_varlocals[arg2]=beam_X[arg1];
2601 #if !Fast_go
2602 { Cell *a;
2603 a = (Cell *) deref(beam_X[arg1]);
2604 if(isvar(a) && !isappl(a) && !is_perm_var(a))
2605 abort_eam("S�rio problema no get_var_Y\n");
2606 /* acho que vou ter de criar uma variavel local nova no nivel superior */
2607 }
2608 #endif
2609 beam_pc+=3;
2610 execute_next();
2611
2612 get_val_X:
2613 #if Debug
2614 printf("%5d->get_val_X X%d,X%d \n",contador++,(int) arg1,(int) arg2);
2615 break_debug(contador);
2616 #endif
2617 { register Cell *_DR, *_DR1;
2618 _DR=(Cell *) deref(beam_X[arg1]);
2619 if (isvar((Cell) _DR)) {
2620 _DR1=(Cell *) deref(beam_X[arg2]);
2621 if (!isvar((Cell) _DR1)) {
2622 *(_DR)=(Cell) _DR1;
2623 trail(beam_ABX,(struct PERM_VAR *) _DR);
2624 } else {
2625 UnifyCells(_DR,_DR1);
2626 }
2627 } else {
2628 _DR1=(Cell *) deref(beam_X[arg2]);
2629 if (isvar((Cell) _DR1)) {
2630 *(_DR1)=(Cell) _DR;
2631 trail(beam_ABX,(struct PERM_VAR *) _DR1);
2632 } else {
2633 if (!Unify(_DR1,_DR)) goto fail_head;
2634 }
2635 }
2636 }
2637 beam_pc+=3;
2638 execute_next();
2639
2640 get_val_Y:
2641 #if Debug
2642 printf("%5d->get_val_Y X%d,Y%d \n",contador++,(int) arg1,(int) arg2);
2643 break_debug(contador);
2644 #endif
2645 { register Cell *_DR, *_DR1;
2646 _DR=(Cell *) deref(beam_X[arg1]);
2647 if (isvar((Cell) _DR)) {
2648 _DR1=(Cell *) deref(beam_varlocals[arg2]);
2649 if (!isvar((Cell) _DR1)) {
2650 *(_DR)=(Cell) _DR1;
2651 trail(beam_ABX,(struct PERM_VAR *) _DR);
2652 } else {
2653 UnifyCells(_DR,_DR1);
2654 }
2655 } else {
2656 _DR1=(Cell *) deref(beam_varlocals[arg2]);
2657 if (isvar((Cell) _DR1)) {
2658 *(_DR1)=(Cell) _DR;
2659 trail(beam_ABX,(struct PERM_VAR *) _DR1);
2660 } else {
2661 if (!Unify(_DR1,_DR)) goto fail_head;
2662 }
2663 }
2664 }
2665 beam_pc+=3;
2666 execute_next();
2667
2668 get_atom:
2669 #if Debug
2670 printf("%5d->get_atom X%d, 0x%lX\n",contador++,(int) arg1,(unsigned long) arg2);
2671 break_debug(contador);
2672 #endif
2673 { register Cell *_DR;
2674 _DR=(Cell *) deref(beam_X[arg1]);
2675 if (isvar((Cell) _DR)) {
2676 *(_DR)=arg2;
2677 trail(beam_ABX,(struct PERM_VAR *) _DR);
2678 } else {
2679 if ((Cell) _DR!=arg2) goto fail_head;
2680 }
2681 }
2682 beam_pc+=3;
2683 execute_next();
2684
2685 get_list:
2686 #if Debug
2687 printf("%5d->get_list X%d\n",contador++,(int) arg1);
2688 break_debug(contador);
2689 #endif
2690 { register Cell *_DR, *_DR1;
2691 _DR=(Cell *) deref(beam_X[arg1]);
2692 if (isvar((Cell) _DR)) { beam_Mode=WRITE;
2693 beam_S = beam_H;
2694 beam_H+= 2;
2695 _DR1=(Cell *) abspair(beam_S);
2696 *(_DR)=(Cell) _DR1;
2697 trail(beam_ABX,(struct PERM_VAR *) _DR);
2698 beam_pc+=2;
2699 execute_next();
2700 } else {
2701 if (!ispair((Cell) _DR)) goto fail_head;
2702 beam_Mode=READ;
2703 _DR1=_DR; /* SaveExpression in DR1*/
2704 beam_S=(Cell *) reppair((Cell) _DR);
2705 beam_pc+=2;
2706 execute_next();
2707 }
2708 }
2709
2710 get_struct:
2711 #if Debug
2712 printf("%5d->get_struct X%d, 0x%lX/%d\n",contador++,(int) arg1,(unsigned long) arg2,(int) arg3);
2713 break_debug(contador);
2714
2715 #endif
2716 { register Cell *_DR, *_DR1;
2717 _DR=(Cell *) deref(beam_X[arg1]);
2718 if (isvar((Cell) _DR)) { beam_Mode=WRITE;
2719 _DR1=(Cell *) absappl((Cell) beam_H); /* SaveExpression in _DR1*/
2720 *(_DR)=(Cell) _DR1;
2721 trail(beam_ABX,(struct PERM_VAR *) _DR);
2722 *( beam_H++)=arg2;
2723 beam_S= beam_H;
2724 beam_H+=arg3; /* arg3 = arity */
2725 beam_pc+=4;
2726 execute_next();
2727 } else {
2728 if (!isappl((Cell) _DR)) goto fail_head;
2729 beam_Mode=READ;
2730 beam_S=(Cell *) repappl((Cell) _DR);
2731 if (*beam_S!=arg2) goto fail_head;
2732 beam_S++;
2733 _DR1=_DR; /* SaveExpression in _DR1*/
2734 beam_pc+=4;
2735 execute_next();
2736 }
2737 }
2738
2739 unify_void:
2740 #if Debug
2741 printf("%5d->unify_void\n",contador++);
2742 break_debug(contador);
2743 #endif
2744 if (beam_Mode==WRITE) {
2745 *beam_S=(Cell) request_permVar(beam_ABX);
2746 }
2747 beam_S++;
2748 beam_pc+=1;
2749 execute_next();
2750
2751
2752 unify_local_Y:
2753 #if Debug
2754 printf("%5d->unify_local_Y Y%d \n",contador++,(int) arg1);
2755 break_debug(contador);
2756
2757 #endif
2758 if (beam_Mode==READ) {
2759 register Cell *_DR, *_DR1;
2760 _DR1=(Cell *) deref(beam_varlocals[arg1]);
2761 if (isvar((Cell) _DR1)) {
2762 _DR=(Cell *) deref((Cell) beam_S);
2763 if (isvar((Cell) _DR)) {
2764 UnifyCells(_DR1,_DR); /* var , var */
2765 } else {
2766 *(_DR1)=(Cell) _DR; /* var , nonvar */
2767 trail(beam_ABX,(struct PERM_VAR *) _DR1);
2768 }
2769 }
2770 else {
2771 _DR=(Cell *) deref((Cell) beam_S);
2772 if (isvar((Cell) _DR)) {
2773 *(_DR)=(Cell) _DR1; /* nonvar, var */
2774 trail(beam_ABX,(struct PERM_VAR *) _DR);
2775 } else {
2776 if (!Unify(_DR,_DR1)) goto fail_head; /* nonvar, nonvar */
2777 }
2778 }
2779 beam_S++;
2780 beam_pc+=2;
2781 execute_next();
2782 } else { /* write Mode */
2783 register Cell *_DR;
2784 _DR=(Cell *) deref(beam_varlocals[arg1]);
2785 if (isvar((Cell) _DR) && !is_perm_var((Cell *) _DR)) {
2786 *beam_S=(Cell) request_permVar(beam_ABX);
2787 UnifyCells(_DR,beam_S);
2788 } else {
2789 *(beam_S)=(Cell) _DR;
2790 }
2791 beam_S++;
2792 beam_pc+=2;
2793 execute_next();
2794 }
2795
2796 unify_local_X:
2797 #if Debug
2798 printf("%5d->unify_local_X X%d \n",contador++,(int) arg1);
2799 break_debug(contador);
2800 #endif
2801 if (beam_Mode==READ) {
2802 register Cell *_DR, *_DR1;
2803 _DR1=(Cell *) deref(beam_X[arg1]);
2804 if (isvar((Cell) _DR1)) {
2805 _DR=(Cell *) deref((Cell) beam_S);
2806 if (isvar((Cell) _DR)) {
2807 UnifyCells(_DR1,_DR); /* var , var */
2808 } else {
2809 *(_DR1)=(Cell) _DR; /* var , nonvar */
2810 trail(beam_ABX,(struct PERM_VAR *) _DR1);
2811 }
2812 }
2813 else {
2814 _DR=(Cell *) deref((Cell) beam_S);
2815 if (isvar((Cell) _DR)) {
2816 *(_DR)=(Cell) _DR1; /* nonvar, var */
2817 trail(beam_ABX,(struct PERM_VAR *) _DR);
2818 } else {
2819 if (!Unify(_DR,_DR1)) goto fail_head; /* nonvar, nonvar */
2820 }
2821 }
2822 beam_S++;
2823 beam_pc+=2;
2824 execute_next();
2825 } else { /* write mode */
2826 register Cell *_DR;
2827 _DR=(Cell *) deref(beam_X[arg1]);
2828
2829 if (isvar((Cell) _DR) && !is_perm_var((Cell *) _DR)) {
2830 *beam_S=(Cell) request_permVar(beam_ABX);
2831 UnifyCells(_DR,beam_S);
2832 } else {
2833 *(beam_S)=(Cell) _DR;
2834 }
2835 beam_S++;
2836 beam_pc+=2;
2837 execute_next();
2838 }
2839
2840 unify_val_Y:
2841 #if Debug
2842 printf("%5d->unify_val_Y Y%d \n",contador++,(int) arg1);
2843 break_debug(contador);
2844
2845 #endif
2846 if (beam_Mode==READ) {
2847 register Cell *_DR, *_DR1;
2848 _DR1=(Cell *) deref(beam_varlocals[arg1]);
2849 if (isvar((Cell) _DR1)) {
2850 _DR=(Cell *) deref((Cell) beam_S);
2851 if (isvar((Cell) _DR)) {
2852 UnifyCells(_DR1,_DR);
2853 } else {
2854 *(_DR1)=(Cell) _DR;
2855 trail(beam_ABX,(struct PERM_VAR *) _DR1);
2856 }
2857 }
2858 else {
2859 _DR=(Cell *) deref((Cell) beam_S);
2860 if (isvar((Cell) _DR)) {
2861 *(_DR)=(Cell) _DR1;
2862 trail(beam_ABX,(struct PERM_VAR *) _DR);
2863 } else {
2864 if (!Unify(_DR,_DR1)) goto fail_head;
2865 }
2866 }
2867 beam_S++;
2868 beam_pc+=2;
2869 execute_next();
2870 } else { /* write mode */
2871 *(beam_S)=beam_varlocals[arg1];
2872 beam_S++;
2873 beam_pc+=2;
2874 execute_next();
2875 }
2876
2877
2878 unify_val_X:
2879 #if Debug
2880 printf("%5d->unify_val_X X%d \n",contador++,(int) arg1);
2881 break_debug(contador);
2882 #endif
2883 if (beam_Mode==READ) {
2884 register Cell *_DR, *_DR1;
2885 _DR1=(Cell *) deref((Cell) beam_X[arg1]);
2886 if (isvar((Cell) _DR1)) {
2887 _DR=(Cell *) deref((Cell) beam_S);
2888 if (isvar((Cell) _DR)) {
2889 UnifyCells(_DR1,_DR);
2890 } else {
2891 *(_DR1)=(Cell) _DR;
2892 trail(beam_ABX,(struct PERM_VAR *) _DR1);
2893 }
2894 }
2895 else {
2896 _DR=(Cell *) deref((Cell) beam_S);
2897 if (isvar((Cell) _DR)) {
2898 *(_DR)=(Cell) _DR1;
2899 trail(beam_ABX,(struct PERM_VAR *) _DR);
2900 } else {
2901 if (!Unify(_DR,_DR1)) goto fail_head;
2902 }
2903 }
2904 beam_S++;
2905 beam_pc+=2;
2906 execute_next();
2907 } else {
2908 *(beam_S)=beam_X[arg1];
2909 beam_S++;
2910 beam_pc+=2;
2911 execute_next();
2912 }
2913
2914 unify_var_X:
2915 #if Debug
2916 printf("%5d->unify_var_X X%d=*S \n",contador++,(int) arg1);
2917 break_debug(contador);
2918 #endif
2919 if (beam_Mode==READ) {
2920 beam_X[arg1]=*(beam_S++);
2921 beam_pc+=2;
2922 execute_next();
2923 } else {
2924 *beam_S=(Cell) request_permVar(beam_ABX);
2925 beam_X[arg1]=(Cell) beam_S;
2926 beam_S++;
2927 beam_pc+=2;
2928 execute_next();
2929 }
2930
2931 unify_var_Y:
2932 #if Debug
2933 printf("%5d->unify_var_Y Y%d \n",contador++,(int) arg1);
2934 break_debug(contador);
2935 #endif
2936 if (beam_Mode==READ) {
2937 beam_varlocals[arg1]=*(beam_S++);
2938 beam_pc+=2;
2939 execute_next();
2940 } else {
2941 *beam_S=(Cell )request_permVar(beam_ABX);
2942 beam_varlocals[arg1]=*beam_S;
2943 beam_S++;
2944 beam_pc+=2;
2945 execute_next();
2946 }
2947
2948 unify_last_atom:
2949 unify_atom:
2950 #if Debug
2951 printf("%5d->unify_atom 0x%lX \n",contador++,(unsigned long) arg1);
2952 break_debug(contador);
2953 #endif
2954 if (beam_Mode==READ) {
2955 register Cell *_DR;
2956 _DR=(Cell *) deref((Cell) beam_S);
2957 if (isvar((Cell) _DR)) {
2958 *(_DR)=arg1;
2959 trail(beam_ABX,(struct PERM_VAR *) _DR);
2960 } else {
2961 if ((Cell) _DR!=arg1) goto fail_head;
2962 }
2963 beam_S++;
2964 beam_pc+=2;
2965 execute_next();
2966 } else {
2967 *(beam_S)=arg1;
2968 beam_S++;
2969 beam_pc+=2;
2970 execute_next();
2971 }
2972
2973 unify_list:
2974 #if Debug
2975 printf("%5d->unify_list \n",contador++);
2976 break_debug(contador);
2977 #endif
2978 if (beam_Mode==READ) {
2979 register Cell *_DR, *_DR1;
2980 _DR=(Cell *) deref(*beam_S);
2981 if (isvar((Cell) _DR)) {
2982 _DR1=(Cell *) abspair((Cell) beam_H); /* SavedExpression in _DR1 */
2983 *(_DR)=(Cell) _DR1;
2984 trail(beam_ABX,(struct PERM_VAR *) _DR);
2985 beam_S++;
2986 push_mode_and_sreg();
2987 beam_Mode=WRITE; /* goes int write mode */
2988 beam_S= beam_H;
2989 beam_H+=2;
2990 beam_pc+=1;
2991 execute_next();
2992 } else {
2993 if (!ispair((Cell) _DR)) goto fail_head;
2994 beam_S++;
2995 push_mode_and_sreg();
2996 beam_S=(Cell *) reppair((Cell) _DR);
2997 _DR1=_DR; /* SavedExpression in _DR1 */
2998 beam_pc+=1;
2999 execute_next();
3000 }
3001 } else {
3002 register Cell *_DR1;
3003 _DR1=(Cell *) abspair((Cell) beam_H); /* SavedExpression in _DR1 */
3004 *(beam_S)=(Cell) _DR1;
3005 beam_S++;
3006 push_mode_and_sreg();
3007 beam_S= beam_H;
3008 beam_H+=2;
3009 beam_pc+=1;
3010 execute_next();
3011 }
3012
3013 unify_last_list:
3014 #if Debug
3015 printf("%5d->unify_last_list \n",contador++);
3016 break_debug(contador);
3017 #endif
3018 if (beam_Mode==READ) {
3019 register Cell *_DR, *_DR1;
3020 _DR=(Cell *) deref(*beam_S);
3021 if (isvar((Cell) _DR)) { beam_Mode=WRITE; /* goes into write mode */
3022 _DR1=(Cell *) abspair((Cell) beam_H); /* SavedExpression in _DR1 */
3023 *(_DR)=(Cell) _DR1;
3024 trail(beam_ABX,(struct PERM_VAR *) _DR);
3025 beam_S= beam_H;
3026 beam_H+=2;
3027 beam_pc+=1;
3028 execute_next();
3029 } else {
3030 if (!ispair((Cell) _DR)) goto fail_head;
3031 beam_S=(Cell *) reppair((Cell) _DR);
3032 _DR1=_DR; /* SavedExpression in _DR1 */
3033 beam_pc+=1;
3034 execute_next();
3035 }
3036 } else {
3037 register Cell *_DR1;
3038 _DR1=(Cell *) abspair((Cell) beam_H); /* SavedExpression in _DR1 */
3039 *(beam_S)=(Cell) _DR1;
3040 beam_S= beam_H;
3041 beam_H+=2;
3042 beam_pc+=1;
3043 execute_next();
3044 }
3045
3046 unify_struct:
3047 #if Debug
3048 printf("%5d->unify_struct 0x%lX,%d \n",contador++,(unsigned long) arg1,(int) arg2);
3049 break_debug(contador);
3050 #endif
3051 if (beam_Mode==READ) {
3052 register Cell *_DR, *_DR1;
3053 _DR=(Cell *) deref(*beam_S);
3054 if (isvar((Cell) _DR)) {
3055 _DR1=(Cell *) absappl((Cell) beam_H); /* SaveExpression in _DR1*/
3056 *(_DR)=(Cell) _DR1;
3057 trail(beam_ABX,(struct PERM_VAR *) _DR);
3058 beam_S++;
3059 push_mode_and_sreg();
3060 beam_Mode=WRITE; /* goes into write mode */
3061 *( beam_H++)=arg1;
3062 beam_S= beam_H;
3063 beam_H+=arg2;
3064 beam_pc+=3;
3065 execute_next();
3066 } else {
3067 if (!isappl((Cell) _DR)) goto fail_head;
3068 _DR1=(Cell *) repappl((Cell) _DR);
3069 if (*_DR1!=arg1) goto fail_head;
3070 ++beam_S;
3071 push_mode_and_sreg();
3072 beam_S=++_DR1;
3073 _DR1=_DR; /* SaveExpression in _DR1*/
3074 beam_pc+=3;
3075 execute_next();
3076 }
3077 } else {
3078 register Cell *_DR1;
3079 _DR1=(Cell *) absappl((Cell) beam_H); /* SaveExpression in _DR1*/
3080 *(beam_S)=(Cell) _DR1;
3081 beam_S++;
3082 push_mode_and_sreg();
3083 *( beam_H++)=arg1;
3084 beam_S= beam_H;
3085 beam_H+=arg2;
3086 beam_pc+=3;
3087 execute_next();
3088 }
3089
3090 unify_last_struct:
3091 #if Debug
3092 printf("%5d->unify_last_struct 0x%lX, %d \n",contador++,(unsigned long) arg1,(int) arg2);
3093 break_debug(contador);
3094 #endif
3095 if (beam_Mode==READ) {
3096 register Cell *_DR, *_DR1;
3097 _DR=(Cell *) deref(*beam_S);
3098 if (isvar((Cell) _DR)) { beam_Mode=WRITE; /* goes into write mode */
3099 _DR1=(Cell *) absappl((Cell) beam_H); /* SaveExpression in _DR1*/
3100 *(_DR)=(Cell) _DR1;
3101 trail(beam_ABX,(struct PERM_VAR *) _DR);
3102 *( beam_H++)=arg1;
3103 beam_S= beam_H;
3104 beam_H+=arg2;
3105 beam_pc+=3;
3106 execute_next();
3107 } else {
3108 if (!isappl((Cell) _DR)) goto fail_head;
3109 _DR1=(Cell *) repappl((Cell) _DR);
3110 if (*_DR1!=arg1) goto fail_head;
3111 beam_S=++_DR1;
3112 _DR1=_DR; /* SaveExpression in _DR1*/
3113 beam_pc+=3;
3114 execute_next();
3115 }
3116 } else {
3117 register Cell *_DR1;
3118 _DR1=(Cell *) absappl((Cell) beam_H); /* SaveExpression in _DR1*/
3119 *(beam_S)=(Cell) _DR1;
3120 *( beam_H++)=arg1;
3121 beam_S= beam_H;
3122 beam_H+=arg2;
3123 beam_pc+=3;
3124 execute_next();
3125 }
3126
3127 put_var_X:
3128 #if Debug
3129 printf("%5d->put_var_X X%d,X%d \n",contador++,(int) arg1,(int) arg2);
3130 break_debug(contador);
3131 #endif
3132 beam_X[arg1]=(Cell) beam_H;
3133 beam_X[arg2]=(Cell) beam_H;
3134 *(beam_H)=(Cell) beam_H;
3135 beam_H++;
3136 beam_pc+=3;
3137 execute_next();
3138
3139
3140
3141 put_val_X:
3142 #if Debug
3143 printf("%5d->put_val_X X%d,X%d \n",contador++,(int) arg1,(int) arg2);
3144 break_debug(contador);
3145 #endif
3146 beam_X[arg1]=beam_X[arg2];
3147 beam_pc+=3;
3148 execute_next();
3149
3150
3151 put_var_P:
3152 #if Debug
3153 printf("%5d->put_var_P X%d,Y%d \n",contador++,(int) arg1,(int) arg2);
3154 break_debug(contador);
3155 #endif
3156 if (isvar(beam_varlocals[arg2]) && !is_perm_var((Cell *) beam_varlocals[arg2]))
3157 beam_varlocals[arg2]=(Cell) request_permVar(beam_ABX);
3158 beam_X[arg1]=beam_varlocals[arg2];
3159 beam_pc+=3;
3160 execute_next();
3161
3162 put_var_Y:
3163 /*
3164 #if Debug
3165 printf("%5d->put_var_Y X%d,Y%d \n",contador++,(int) arg1,(int) arg2);
3166 break_debug(contador);
3167
3168 #endif
3169 { register Cell *a;
3170 a = &(beam_varlocals[arg2]);
3171 *a=(Cell) a;
3172 beam_X[arg1]=(Cell) a; }
3173 beam_pc+=3;
3174 execute_next();
3175 */
3176 put_val_Y:
3177 #if Debug
3178 printf("%5d->put_val_Y X%d,Y%d \n",contador++,(int) arg1,(int) arg2);
3179 break_debug(contador);
3180 #endif
3181 beam_X[arg1]=beam_varlocals[arg2];
3182 beam_pc+=3;
3183 execute_next();
3184
3185 put_unsafe:
3186 #if Debug
3187 printf("%5d->put_unsafe X%d, Y%d \n",contador++,(int) arg1,(int) arg2);
3188 break_debug(contador);
3189 #endif
3190 beam_X[arg1]=beam_varlocals[arg2];
3191 beam_pc+=3;
3192 execute_next();
3193
3194
3195 put_atom:
3196 #if Debug
3197 printf("%5d->put_atom X%d, 0x%lX \n",contador++,(int) arg1,(unsigned long) arg2);
3198 break_debug(contador);
3199 #endif
3200 beam_X[arg1]=arg2;
3201 beam_pc+=3;
3202 execute_next();
3203
3204 put_list:
3205 #if Debug
3206 printf("%5d->put_list X%d \n",contador++,(int) arg1);
3207 break_debug(contador);
3208 #endif
3209 { register Cell *_DR1;
3210
3211 _DR1=(Cell *) abspair((Cell) beam_H); /* SaveExpression in _DR1*/
3212 beam_X[arg1]=(Cell) _DR1;
3213 beam_S=beam_H;
3214 beam_H+=2;
3215 beam_pc+=2;
3216 execute_next();
3217 }
3218
3219 put_struct:
3220 #if Debug
3221 printf("%5d->put_struct X%d, 0x%lX, %d \n",contador++,(int) arg1,(unsigned long) arg2,(int) arg3);
3222 break_debug(contador);
3223 #endif
3224 { register Cell _DR1;
3225
3226 _DR1=absappl((Cell) beam_H); /* SaveExpression in _DR1*/
3227 beam_X[arg1]=(Cell) _DR1;
3228 *(beam_H++)=arg2;
3229 beam_S=beam_H;
3230 beam_H+=arg3;
3231 beam_pc+=4;
3232 execute_next();
3233 }
3234
3235 write_var_X:
3236 #if Debug
3237 printf("%5d->write_var_X X%d \n",contador++,(int) arg1);
3238 break_debug(contador);
3239 #endif
3240 *beam_S=(Cell) request_permVar(beam_ABX);
3241 beam_X[arg1]=(Cell) beam_S;
3242 beam_S++;
3243 beam_pc+=2;
3244 execute_next();
3245
3246 write_var_Y:
3247 #if Debug
3248 printf("%5d->write_var_Y Y%d \n",contador++,(int) arg1);
3249 break_debug(contador);
3250 #endif
3251 { Cell *c;
3252 c=&beam_varlocals[arg1];
3253 *c=(Cell) c;
3254 *beam_S=(Cell) c;
3255 }
3256 beam_S++;
3257 beam_pc+=2;
3258 execute_next();
3259
3260
3261 write_var_P:
3262 #if Debug
3263 printf("%5d->write_var_P Y%d \n",contador++,(int) arg1);
3264 break_debug(contador);
3265 #endif
3266 if (isvar(beam_varlocals[arg1]) && !is_perm_var((Cell *) beam_varlocals[arg1]))
3267 beam_varlocals[arg1]=(Cell) request_permVar(beam_ABX);
3268 *(beam_S)=beam_varlocals[arg1];
3269 beam_S++;
3270 beam_pc+=2;
3271 execute_next();
3272
3273
3274 write_local_X:
3275 write_val_X:
3276 #if Debug
3277 printf("%5d->write_val_X X%d (or write_local)\n",contador++,(int) arg1);
3278 break_debug(contador);
3279 #endif
3280 *(beam_S)=beam_X[arg1];
3281 beam_S++;
3282 beam_pc+=2;
3283 execute_next();
3284
3285 write_local_Y:
3286 write_val_Y:
3287 #if Debug
3288 printf("write_val_Y Y%d (or write_local)\n",(int) arg1);
3289 #endif
3290 *(beam_S)=beam_varlocals[arg1];
3291 beam_S++;
3292 beam_pc+=2;
3293 execute_next();
3294
3295 write_void:
3296 #if Debug
3297 printf("%5d->write_void \n",contador++);
3298 break_debug(contador);
3299 #endif
3300 *beam_S=(Cell) request_permVar(beam_ABX);
3301 beam_S++;
3302 beam_pc+=1;
3303 execute_next();
3304 write_atom:
3305 #if Debug
3306 printf("%5d->write_atom 0x%lX \n",contador++,(unsigned long) arg1);
3307 break_debug(contador);
3308 #endif
3309 *(beam_S)=arg1;
3310 beam_S++;
3311 beam_pc+=2;
3312 execute_next();
3313
3314
3315 write_list:
3316 #if Debug
3317 printf("%5d->write_list \n",contador++);
3318 break_debug(contador);
3319 #endif
3320 { register Cell *_DR1;
3321
3322 _DR1=(Cell *) abspair((Cell) beam_H); /* SaveExpression in _DR1*/
3323 *(beam_S++)=(Cell) _DR1;
3324 push_mode_and_sreg();
3325 beam_S=beam_H;
3326 beam_H+=2;
3327 beam_pc+=1;
3328 execute_next();
3329 }
3330
3331 write_last_list:
3332 #if Debug
3333 printf("%5d->write_last_list \n",contador++);
3334 break_debug(contador);
3335 #endif
3336 { register Cell *_DR1;
3337
3338 _DR1=(Cell *) abspair((Cell) beam_H); /* SaveExpression in _DR1*/
3339 *(beam_S)=(Cell) _DR1;
3340 beam_S=beam_H;
3341 beam_H+=2;
3342 beam_pc+=1;
3343 execute_next();
3344 }
3345
3346 write_struct:
3347 #if Debug
3348 printf("%5d->write_struct 0x%lX, %d \n",contador++,(unsigned long) arg1,(int) arg2);
3349 break_debug(contador);
3350 #endif
3351 { register Cell *_DR1;
3352
3353 _DR1=(Cell *) absappl((Cell) beam_H); /* SaveExpression in _DR1*/
3354 *(beam_S++)=(Cell) _DR1;
3355 push_mode_and_sreg();
3356 *(beam_H++)=arg1;
3357 beam_S=beam_H;
3358 beam_H+=arg2;
3359 beam_pc+=3;
3360 execute_next();
3361 }
3362
3363 write_last_struct:
3364 #if Debug
3365 printf("%5d->write_last_struct 0x%lX, %d \n",contador++,(unsigned long) arg1,(int) arg2);
3366 break_debug(contador);
3367 #endif
3368 { register Cell *_DR1;
3369 _DR1=(Cell *) absappl((Cell) beam_H); /* SaveExpression in _DR1*/
3370 *(beam_S)=(Cell) _DR1;
3371 *(beam_H++)=arg1;
3372 beam_S=beam_H;
3373 beam_H+=arg2;
3374 beam_pc+=3;
3375 execute_next();
3376 }
3377
3378 cut:
3379 #if Debug
3380 printf("%5d->cut na alternativa %p� de %d \n",contador++,beam_ABX->nr_alternative, beam_ABX->parent->nr_all_alternatives);
3381 break_debug(contador);
3382 #endif
3383 beam_OBX=beam_ABX->parent;
3384 {
3385 struct status_or *new;
3386 if (!is_leftmost(beam_ABX,beam_nr_call)) {
3387 #if Debug
3388 printf("Force Waiting Before Cut\n");
3389 #endif
3390 beam_nr_call->call=NULL;
3391 beam_nr_call->state=WAITING_TO_BE_LEFTMOST;
3392 beam_ABX->suspended=addto_suspensions_list(beam_ABX,LEFTMOST_SUSPENSION);
3393 beam_nr_call=beam_nr_call->next;
3394 goto next_call;
3395 }
3396 beam_ABX->side_effects-=CUT;
3397 beam_nr_call=remove_call_from_andbox(beam_nr_call,beam_ABX);
3398 #if Debug
3399 printf("Executando o cut \n");
3400 if (beam_ABX->externals!=NULL && beam_OBX->nr_all_alternatives>1) printf("cut com externals (noisy) \n");
3401 if (beam_ABX->externals!=NULL && beam_OBX->nr_all_alternatives==1) printf("cut com externals (degenerate) \n");
3402 #endif
3403 beam_nr_alternative=beam_ABX->nr_alternative;
3404 new=beam_nr_alternative->next;
3405 beam_nr_alternative->next=NULL;
3406 if (new!=NULL) {
3407 do{
3408 struct status_or *old;
3409 old=new;
3410 new=new->next;
3411 del_andbox_and_sons(old->alternative);
3412 if (new==NULL) remove_memory_arguments(old->args);
3413 free_memory((Cell *) old,STATUS_OR_SIZE);
3414 beam_OBX->nr_all_alternatives--;
3415 } while (new!=NULL);
3416 if (beam_OBX->nr_all_alternatives==1) {
3417 beam_nr_alternative=beam_OBX->alternatives;
3418 goto unique_alternative;
3419 }
3420 }
3421 goto next_call;
3422 }
3423
3424 commit:
3425 #if Debug
3426 printf("%5d->commit na alternativa %p� de %d \n",contador++,beam_ABX->nr_alternative, beam_ABX->parent->nr_all_alternatives);
3427 break_debug(contador);
3428 #endif
3429 beam_OBX=beam_ABX->parent;
3430 {
3431 struct status_or *new;
3432 if (!is_leftmost(beam_OBX->parent,beam_OBX->nr_call)) {
3433 #if Debug
3434 printf("Force Waiting Before Commit\n");
3435 #endif
3436 beam_nr_call->call=NULL;
3437 beam_nr_call->state=WAITING_TO_BE_LEFTMOST_PARENT;
3438 beam_ABX->suspended=addto_suspensions_list(beam_ABX,LEFTMOST_SUSPENSION);
3439 beam_nr_call=beam_nr_call->next;
3440 goto next_call;
3441 }
3442 beam_ABX->side_effects-=CUT;
3443 beam_nr_call=remove_call_from_andbox(beam_nr_call,beam_ABX);
3444
3445 #if Debug
3446 printf("Executando o commit (apaga %d alternatives) \n",beam_OBX->nr_all_alternatives-1);
3447 if (beam_ABX->externals!=NULL && beam_OBX->nr_all_alternatives>1) printf("commit com externals (noisy) \n");
3448 if (beam_ABX->externals!=NULL && beam_OBX->nr_all_alternatives==1) printf("commit com externals (degenerate) \n");
3449 #endif
3450
3451 if (beam_OBX->nr_all_alternatives>1) {
3452 beam_nr_alternative=beam_ABX->nr_alternative;
3453 beam_OBX->nr_all_alternatives=1;
3454 new=beam_OBX->alternatives;
3455 beam_OBX->alternatives=beam_nr_alternative; /* fica a ser a unica alternativa */
3456 do {
3457 struct status_or *old;
3458 old=new;
3459 new=new->next;
3460 if (old!=beam_nr_alternative) {
3461 del_andbox_and_sons(old->alternative);
3462 if (new==NULL) remove_memory_arguments(old->args);
3463 free_memory((Cell *) old,STATUS_OR_SIZE);
3464 }
3465 } while (new!=NULL);
3466 beam_nr_alternative->next=NULL;
3467 beam_nr_alternative->previous=NULL;
3468 }
3469 goto unique_alternative;
3470 }
3471
3472 jump:
3473 #if Debug
3474 printf("%5d->jump inst %ld\n",contador++,(long int) arg1);
3475 break_debug(contador);
3476 #endif
3477 beam_pc=(Cell *) arg1;
3478 execute_next();
3479
3480
3481 save_pair_Y:
3482 #if Debug
3483 printf("%5d->save_pair Y%ld\n",contador++,(long int) arg1);
3484 break_debug(contador);
3485 #endif
3486 abort_eam("save_exp no emulador ?????");
3487 --S;
3488 beam_varlocals[arg1]=abspair(beam_S);
3489 ++S;
3490 beam_pc+=2;
3491 execute_next();
3492
3493 save_appl_Y:
3494 #if Debug
3495 printf("%5d->save_appl Y%ld\n",contador++,(long int) arg1);
3496 break_debug(contador);
3497 #endif
3498 abort_eam("save_exp no emulador ?????");
3499 --S;
3500 beam_varlocals[arg1]=absappl(beam_S);
3501 ++S;
3502 beam_pc+=2;
3503 execute_next();
3504
3505
3506 save_appl_X:
3507 #if Debug
3508 printf("%5d->save_appl X%ld\n",contador++,(long int) arg1);
3509 break_debug(contador);
3510 #endif
3511 abort_eam("save_exp no emulador ?????");
3512 --S;
3513 beam_X[arg1]=absappl(beam_S);
3514 ++S;
3515 beam_pc+=2;
3516 execute_next();
3517
3518 save_pair_X:
3519 #if Debug
3520 printf("%5d->save_pair X%ld\n",contador++,(long int) arg1);
3521 break_debug(contador);
3522 #endif
3523 abort_eam("save_exp no emulador ?????");
3524 --S;
3525 beam_X[arg1]=abspair(beam_S);
3526 ++S;
3527 beam_pc+=2;
3528 execute_next();
3529
3530 p_atom:
3531 p_atomic:
3532 p_integer:
3533 p_nonvar:
3534 p_number:
3535 p_var:
3536 p_db_ref:
3537 p_primitive:
3538 p_cut_by:
3539 p_succ:
3540 p_predc:
3541 p_plus:
3542 p_minus:
3543 p_times:
3544 p_div:
3545 p_equal:
3546 p_dif:
3547 p_eq:
3548 p_arg:
3549 p_functor:
3550
3551 abort_eam("std_pred no emulador ?????");
3552 orelse:
3553 orlast:
3554 either:
3555 abort_eam("either/orelse/orlast ainda nao implementadas ?????");
3556
3557 save_b_X:
3558 save_b_Y:
3559 comit_b_X:
3560 comit_b_Y:
3561 abort_eam("save_b_X/Y ou comit_b_X/Y no emulador ?????\n");
3562
3563 }
3564 return (TRUE);
3565 }
3566
3567 /* The Inst_am instruction is used in eamamasm.c */
3568
3569 Cell inst_am(int n);
3570 Cell am_to_inst(Cell inst);
3571
3572 Cell inst_am(int n)
3573 {
3574 #if DIRECT_JUMP
3575 if (TABLE_OPS==NULL) eam_am(NULL);
3576 return TABLE_OPS[n];
3577 #else
3578 return(n);
3579 #endif
3580 }
3581
3582 Cell am_to_inst(Cell inst)
3583 {
3584 #if DIRECT_JUMP
3585 int n;
3586 for(n=0;n<=_p_functor; n++) if ((Cell) TABLE_OPS[n]==inst) return (n);
3587 #endif
3588
3589 return(inst);
3590 }
3591
3592
3593
3594 #if Debug_Dump_State
3595 /************************************************************************\
3596 * MORE DEBUG STUFF *
3597 \************************************************************************/
3598 #define DUMP_BOXES 0
3599 #define DUMP_STATES 1
3600 #define DUMP_VARS 2
3601
3602
3603 void dump_eam_orbox(struct OR_BOX *o, struct AND_BOX *pai, struct status_and *pai2);
3604 void dump_eam_andbox(struct AND_BOX *a, struct OR_BOX *pai, struct status_or *pai2);
3605 char *SPACES(int level);
3606
3607 #define SPACE_MULT 4
3608 char *SPACES(int level) {
3609 static char spaces[2000];
3610 int i;
3611
3612 for(i=0;i<level*SPACE_MULT;i++) {
3613 spaces[i]=' ';
3614 }
3615 spaces[level*SPACE_MULT]=0;
3616 return (spaces);
3617 }
3618
3619 void dump_eam_state() {
3620 static int nr_state=0;
3621 int nr=0;
3622 printf("State %d:\n",++nr_state);
3623
3624 /* verify suspended boxes */
3625 if (beam_su!=NULL) {
3626 struct SUSPENSIONS *s,*l;
3627 l=beam_su->prev;
3628 s=beam_su;
3629 do {
3630 nr++;
3631 if (s->prev!=l) abort_eam("Invalid list of Suspended boxes\b");
3632 l=s;
3633 s=s->next;
3634 } while(s!=beam_su);
3635 }
3636 printf("%d suspended boxes\n",nr);
3637
3638 dump_eam_andbox(beam_top,NULL, NULL);
3639 }
3640
3641
3642 void dump_eam_andbox(struct AND_BOX *a, struct OR_BOX *pai, struct status_or *pai2) {
3643 struct status_and *calls, *last;
3644
3645 if (a==NULL) return;
3646 if (pai!=a->parent) abort_eam("Pai diferente do parent\n");
3647 if (pai2!=a->nr_alternative) abort_eam("Status call Pai diferente do nralternative\n");
3648 if (a==beam_ABX) printf("->"); else printf(" ");
3649 if (a->suspended) printf("*"); else printf(" ");
3650 printf("%s+ANDBOX with %d goals\n",SPACES(2*(a->level)),a->nr_all_calls);
3651
3652 calls=a->calls;
3653 last=NULL;
3654 while(calls!=NULL) {
3655 if (calls->previous!=last) abort_eam("link errado nos calls\n");
3656 if (calls->locals==NULL) printf(" %sNO local vars\n",SPACES(2*(a->level)+1));
3657 else printf(" %s%d local vars\n",SPACES(2*(a->level)+1),calls->locals[-1]);
3658 if (calls->call==NULL) {
3659 printf(" %s>ORBOX EMPTY\n",SPACES(2*(a->level)+1));
3660 } else {
3661 dump_eam_orbox(calls->call,a,calls);
3662 }
3663 last=calls;
3664 calls=calls->next;
3665 }
3666 // printf("Exit from dum_eam_andbox\n");
3667 }
3668
3669 void dump_eam_orbox(struct OR_BOX *o, struct AND_BOX *pai, struct status_and *pai2) {
3670 struct status_or *i,*last;
3671 if (o==NULL) return;
3672 if (pai!=o->parent) abort_eam("Pai diferente do parent\n");
3673 if (pai2!=o->nr_call) abort_eam("Status call Pai diferente do nrcall\n");
3674 if (o==beam_OBX) printf("=> "); else printf(" ");
3675
3676 printf("%s>ORBOX with %d alternatives\n",SPACES(2*(o->parent->level)+1),o->nr_all_alternatives);
3677
3678 i=o->alternatives;
3679 last=NULL;
3680 while(i!=NULL) {
3681 if (i->previous!=last) abort_eam("link errado nas alternativas\n");
3682 if (i->args) {
3683 printf(" %s+%d Arguments\n",SPACES(2*(o->parent->level+1)),i->args[0]);
3684 if (i->args[0]<0 || i->args[0]>1000) abort_eam("Num Invalido de Args\n");
3685 }
3686 if (i->alternative==NULL) {
3687 printf(" %s+ANDBOX EMPTY\n",SPACES(2*(o->parent->level+2)));
3688 } else {
3689 dump_eam_andbox(i->alternative,o, i);
3690 }
3691 last=i;
3692 i=i->next;
3693 }
3694 }
3695
3696 #endif
3697
3698
3699 #include <sys/time.h>
3700 #include <sys/resource.h>
3701 #include <unistd.h>
3702
3703 int showTime(void) /* MORE PRECISION */
3704 {
3705 static int call_time=0;
3706 static struct timeval StartTime;
3707 static struct timezone TimeZone={0,0};
3708
3709 #if MICRO_TIME
3710 if (!call_time) {
3711 gettimeofday(&StartTime,&TimeZone);
3712 call_time=1;
3713 } else {
3714 struct timeval time,diff;
3715
3716 call_time=0;
3717 gettimeofday(&time,&TimeZone);
3718 diff.tv_sec = time.tv_sec - StartTime.tv_sec;
3719 diff.tv_usec = time.tv_usec - StartTime.tv_usec;
3720 if(diff.tv_usec < 0){
3721 diff.tv_usec += 1000000;
3722 diff.tv_sec -= 1;
3723 }
3724 printf("CPU Time %ld (Microseconds)\n", (diff.tv_sec*1000000)+(diff.tv_usec));
3725 }
3726 return(TRUE);
3727 #else
3728 struct rusage rusage;
3729
3730 /* InitTime() and cputime() from sysbits.c */
3731 if (!call_time) {
3732 getrusage(RUSAGE_SELF, &rusage);
3733 StartTime.tv_sec = rusage.ru_utime.tv_sec;
3734 StartTime.tv_usec = rusage.ru_utime.tv_usec;
3735 call_time=1;
3736 } else {
3737 struct timeval diff;
3738
3739 call_time=0;
3740 getrusage(RUSAGE_SELF, &rusage);
3741 diff.tv_sec = rusage.ru_utime.tv_sec - StartTime.tv_sec;
3742 diff.tv_usec = rusage.ru_utime.tv_usec - StartTime.tv_usec;
3743 if(diff.tv_usec < 0){
3744 diff.tv_usec += 1000000;
3745 diff.tv_sec -= 1;
3746 }
3747 printf("CPU Time %ld (Miliseconds)\n", (diff.tv_sec*1000)+(diff.tv_usec/1000));
3748 }
3749
3750 return(TRUE);
3751 #endif
3752 }
3753
3754
3755
3756
3757
3758 #if USE_SPLIT
3759 #include "eam_split.c"
3760 #endif
3761
3762 #if GARBAGE_COLLECTOR
3763 /************************************************************************\
3764 * GC *
3765 \************************************************************************/
3766
3767 #include "eam_gc.c"
3768 #endif
3769
3770
3771 #endif /* BEAM */
3772