1 /************************************************************************* 2 * * 3 * BEAM -> Basic Extended Andorra Model * 4 * BEAM extends the YAP Prolog system to support the EAM * 5 * * 6 * Copyright: Ricardo Lopes and NCC - University of Porto, Portugal * 7 * * 8 ************************************************************************** 9 * comments: abstract machine assembler * 10 *************************************************************************/ 11 12 #ifdef BEAM 13 14 #include "Yap.h" 15 #include "compile.h" 16 #include "clause.h" 17 #include "eam.h" 18 #include "eamamasm.h" 19 #include <stdio.h> 20 #include <stdlib.h> 21 22 Cell *inst_code; 23 int pass=0; 24 Cell *labels[1000]; 25 26 Cell *Code_Start; 27 Cell Area_Code[200000]; 28 Cell area_code=0; 29 30 extern Cell inst_am(int n); 31 void emit_inst(long int i); 32 void emit_par(long int i); 33 void emit_upar(Cell i); 34 Cell *get_addr(void); 35 int Is_X_Var(Ventry *ve); 36 int Is_P_Var(Ventry *ve); 37 int X_Var(Ventry *ve); 38 int Y_Var(Ventry *ve); 39 void eam_pass(CInstr *ppc); 40 Cell *eam_assemble(CInstr *code); 41 int next_not_nop_inst(CInstr *ppc); 42 extern void *alloc_mem(Cell); 43 emit_inst(long int i)44void emit_inst(long int i) 45 { 46 if (pass) *inst_code=inst_am(i); 47 inst_code++; 48 } 49 emit_par(long int i)50void emit_par(long int i) 51 { 52 if (pass) *inst_code=i; 53 inst_code++; 54 } 55 emit_upar(Cell i)56void emit_upar(Cell i) 57 { 58 if (pass) *inst_code=i; 59 inst_code++; 60 } 61 62 get_addr(void)63Cell *get_addr(void) 64 { 65 return(inst_code); 66 } 67 68 Is_P_Var(Ventry * ve)69int Is_P_Var(Ventry *ve) 70 { 71 if (ve->FirstOfVE>0) return (1); /* var aparece pela primeira no corpo da clausula */ 72 return(0); 73 } 74 Is_X_Var(Ventry * ve)75int Is_X_Var(Ventry *ve) 76 { 77 if (ve->KindOfVE == PermVar) return(0); 78 if (ve->KindOfVE == VoidVar) return(0); 79 80 return(1); 81 } 82 X_Var(Ventry * ve)83int X_Var(Ventry *ve) 84 { 85 int var; 86 87 if (ve->KindOfVE == PermVar || ve->KindOfVE == VoidVar ) { 88 printf("Erro no tipo de variavel X ->eamamas.c \n"); 89 exit(1); 90 } 91 var = ((ve->NoOfVE) & MaskVarAdrs); 92 93 return (var); 94 } 95 96 extern int nperm; 97 Y_Var(Ventry * ve)98int Y_Var(Ventry *ve) 99 { 100 int var; 101 if (ve->KindOfVE != PermVar) { 102 printf("Erro no tipo de variavel Y ->eamamas.c \n"); 103 exit(1); 104 } 105 var = ((ve->NoOfVE) & MaskVarAdrs); 106 return (var); 107 } 108 109 next_not_nop_inst(CInstr * ppc)110int next_not_nop_inst(CInstr *ppc) { 111 while(ppc) { 112 if ((int) ppc->op!=nop_op) return ((int) ppc->op); 113 ppc = ppc->nextInst; 114 } 115 return exit_op; 116 } 117 eam_pass(CInstr * ppc)118void eam_pass(CInstr *ppc) 119 { 120 int alloc_found=0; 121 int body=0; 122 123 while (ppc) { 124 switch ((int) ppc->op) { 125 126 case get_var_op: 127 if (Is_X_Var((Ventry *) ppc->new4)) { 128 emit_inst(_get_var_X_op); 129 emit_par(ppc->new1); 130 emit_par(X_Var((Ventry *) ppc->new4)); 131 } else { 132 emit_inst(_get_var_Y_op); 133 emit_par(ppc->new1); 134 emit_par(Y_Var((Ventry *) ppc->new4)); 135 } 136 break; 137 case get_val_op: 138 if (Is_X_Var((Ventry *) ppc->new4)) { 139 emit_inst(_get_val_X_op); 140 emit_par(ppc->new1); 141 emit_par(X_Var((Ventry *) ppc->new4)); 142 } else { 143 emit_inst(_get_val_Y_op); 144 emit_par(ppc->new1); 145 emit_par(Y_Var((Ventry *) ppc->new4)); 146 } 147 break; 148 149 case get_num_op: 150 case get_atom_op: 151 emit_inst(_get_atom_op); 152 emit_par(ppc->new1); 153 emit_par(ppc->new4); 154 break; 155 156 case get_list_op: 157 emit_inst(_get_list_op); 158 emit_par(ppc->new1); 159 break; 160 case get_struct_op: 161 emit_inst(_get_struct_op); 162 emit_par(ppc->new1); 163 emit_par(ppc->new4); 164 emit_par(ArityOfFunctor((Functor ) ppc->new4)); 165 break; 166 167 case unify_last_local_op: 168 case unify_local_op: 169 if (Is_X_Var((Ventry *) ppc->new4)) { 170 emit_inst(_unify_local_X_op); 171 emit_par(X_Var((Ventry *) ppc->new4)); 172 } else { 173 emit_inst(_unify_local_Y_op); 174 emit_par(Y_Var((Ventry *) ppc->new4)); 175 } 176 break; 177 178 case unify_last_val_op: 179 case unify_val_op: 180 if (((Ventry *)(ppc->new4))->KindOfVE!=VoidVar) { 181 if (Is_X_Var((Ventry *) ppc->new4)) { 182 emit_inst(_unify_val_X_op); 183 emit_par(X_Var((Ventry *) ppc->new4)); 184 } else { 185 emit_inst(_unify_val_Y_op); 186 emit_par(Y_Var((Ventry *) ppc->new4)); 187 188 } 189 } else { emit_inst(_unify_void_op); } 190 break; 191 192 case unify_last_var_op: 193 case unify_var_op: 194 if (((Ventry *)(ppc->new4))->KindOfVE!=VoidVar) { 195 if (Is_X_Var((Ventry *) ppc->new4)) { 196 emit_inst(_unify_var_X_op); 197 emit_par(X_Var((Ventry *) ppc->new4)); 198 } else { 199 emit_inst(_unify_var_Y_op); 200 emit_par(Y_Var((Ventry *) ppc->new4)); 201 } 202 } else { emit_inst(_unify_void_op); } 203 break; 204 205 case unify_last_atom_op: 206 case unify_last_num_op: 207 emit_inst(_unify_last_atom_op); 208 emit_par(ppc->new4); 209 break; 210 case unify_num_op: 211 case unify_atom_op: 212 emit_inst(_unify_atom_op); 213 emit_par(ppc->new4); 214 break; 215 case unify_list_op: 216 emit_inst(_unify_list_op); 217 break; 218 case unify_last_list_op: 219 emit_inst(_unify_last_list_op); 220 break; 221 case unify_struct_op: 222 emit_inst(_unify_struct_op); 223 emit_par(ppc->new4); 224 emit_par(ArityOfFunctor((Functor )ppc->new4)); 225 break; 226 case unify_last_struct_op: 227 emit_inst(_unify_last_struct_op); 228 emit_par(ppc->new4); 229 emit_par(ArityOfFunctor((Functor )ppc->new4)); 230 break; 231 232 case put_unsafe_op: 233 /* 234 printf("Got a put_unsafe...\n"); 235 emit_inst(_put_unsafe_op); 236 emit_par(ppc->new1); 237 emit_par(Y_Var((Ventry *) ppc->new4)); 238 break; 239 */ 240 case put_val_op: 241 /* 242 if (Is_X_Var((Ventry *) ppc->new4)) { 243 emit_inst(_put_val_X_op); 244 emit_par(ppc->new1); 245 emit_par(X_Var((Ventry *) ppc->new4)); 246 break; 247 } else { 248 emit_inst(_put_val_Y_op); 249 emit_par(ppc->new1); 250 emit_par(Y_Var((Ventry *) ppc->new4)); 251 break; 252 } 253 */ 254 case put_var_op: 255 if (Is_X_Var((Ventry *) ppc->new4)) { 256 emit_inst(_put_var_X_op); 257 emit_par(ppc->new1); 258 emit_par(X_Var((Ventry *) ppc->new4)); 259 } else { 260 if (Is_P_Var((Ventry *) ppc->new4)) emit_inst(_put_var_P_op); 261 else emit_inst(_put_var_Y_op); 262 emit_par(ppc->new1); 263 emit_par(Y_Var((Ventry *) ppc->new4)); 264 } 265 break; 266 267 case put_num_op: 268 case put_atom_op: 269 emit_inst(_put_atom_op); 270 emit_par(ppc->new1); 271 emit_par(ppc->new4); 272 break; 273 case put_list_op: 274 emit_inst(_put_list_op); 275 emit_par(ppc->new1); 276 break; 277 case put_struct_op: 278 emit_inst(_put_struct_op); 279 emit_par(ppc->new1); 280 emit_par(ppc->new4); 281 emit_par(ArityOfFunctor((Functor )ppc->new4)); 282 break; 283 284 case write_local_op: 285 if (Is_X_Var((Ventry *) ppc->new4)) { 286 emit_inst(_write_local_X_op); 287 emit_par(X_Var((Ventry *) ppc->new4)); 288 } else { 289 emit_inst(_write_local_Y_op); 290 emit_par(Y_Var((Ventry *) ppc->new4)); 291 } 292 break; 293 294 case write_val_op: 295 if (((Ventry *)(ppc->new4))->KindOfVE!=VoidVar) { 296 if (Is_X_Var((Ventry *) ppc->new4)) { 297 emit_inst(_write_val_X_op); 298 emit_par(X_Var((Ventry *) ppc->new4)); 299 } else { 300 emit_inst(_write_val_Y_op); 301 emit_par(Y_Var((Ventry *) ppc->new4)); 302 } 303 } else emit_inst(_write_void); 304 break; 305 306 case write_var_op: 307 if (((Ventry *)(ppc->new4))->KindOfVE!=VoidVar) { 308 if (Is_X_Var((Ventry *) ppc->new4)) { 309 emit_inst(_write_var_X_op); 310 emit_par(X_Var((Ventry *) ppc->new4)); 311 } else { 312 if (Is_P_Var((Ventry *) ppc->new4)) emit_inst(_write_var_P_op); 313 else emit_inst(_write_var_Y_op); 314 emit_par(Y_Var((Ventry *) ppc->new4)); 315 } 316 } else emit_inst(_write_void); 317 break; 318 319 320 case write_num_op: 321 case write_atom_op: 322 emit_inst(_write_atom_op); 323 emit_par(ppc->new4); 324 break; 325 case write_list_op: 326 emit_inst(_write_list_op); 327 break; 328 case write_last_list_op: 329 emit_inst(_write_last_list_op); 330 break; 331 case write_struct_op: 332 emit_inst(_write_struct_op); 333 emit_par(ppc->new4); 334 emit_par(ArityOfFunctor((Functor )ppc->new4)); 335 break; 336 case write_last_struct_op: 337 emit_inst(_write_last_struct_op); 338 emit_par(ppc->new4); 339 emit_par(ArityOfFunctor((Functor )ppc->new4)); 340 break; 341 342 case fail_op: 343 emit_inst(_fail_op); 344 break; 345 case cutexit_op: 346 printf("cutexit \n"); 347 exit(1); 348 break; 349 350 case cut_op: 351 emit_inst(_cut_op); 352 break; 353 case commit_op: 354 emit_inst(_commit_op); 355 break; 356 357 case procceed_op: 358 emit_inst(_proceed_op); 359 break; 360 case pop_op: 361 emit_inst(_pop_op); 362 emit_par(ppc->new4); 363 break; 364 case save_b_op: 365 if (Is_X_Var((Ventry *) ppc->new4)) { 366 emit_inst(_save_b_X_op); 367 emit_par(X_Var((Ventry *) ppc->new4)); 368 } else { 369 emit_inst(_save_b_Y_op); 370 emit_par(Y_Var((Ventry *) ppc->new4)); 371 } 372 break; 373 case save_pair_op: 374 if (Is_X_Var((Ventry *) ppc->new4)) { 375 emit_inst(_save_pair_X_op); 376 emit_par(X_Var((Ventry *) ppc->new4)); 377 } else { 378 emit_inst(_save_pair_Y_op); 379 emit_par(Y_Var((Ventry *) ppc->new4)); 380 } 381 break; 382 case save_appl_op: 383 if (Is_X_Var((Ventry *) ppc->new4)) { 384 emit_inst(_save_appl_X_op); 385 emit_par(X_Var((Ventry *) ppc->new4)); 386 } else { 387 emit_inst(_save_appl_Y_op); 388 emit_par(Y_Var((Ventry *) ppc->new4)); 389 } 390 break; 391 case std_base_op: 392 emit_inst(_std_base+ppc->new4); 393 break; 394 395 case safe_call_op: 396 if (ppc->new1==1) { 397 emit_inst(_safe_call_unary_op); 398 } else if (ppc->new1==2) { 399 emit_inst(_safe_call_binary_op); 400 } else { 401 emit_inst(_safe_call_op); 402 } 403 emit_par(ppc->new4); 404 break; 405 406 case direct_safe_call_op: 407 if (ppc->new1==1) { 408 emit_inst(_direct_safe_call_unary_op); 409 } else if (ppc->new1==2) { 410 emit_inst(_direct_safe_call_binary_op); 411 } else { 412 emit_inst(_direct_safe_call_op); 413 } 414 emit_par(ppc->new4); 415 break; 416 417 case call_op: 418 emit_inst(_call_op); 419 emit_par(ppc->new4); 420 break; 421 422 case skip_while_var_op: 423 emit_inst(_skip_while_var); 424 break; 425 case wait_while_var_op: 426 emit_inst(_wait_while_var); 427 break; 428 case force_wait_op: 429 emit_inst(_force_wait); 430 break; 431 case write_op: 432 if (ppc->new1=='\n') { 433 static Atom a=NULL; 434 if (a==NULL) a=Yap_LookupAtom("\n"); 435 emit_inst(_put_atom_op); 436 emit_par(1); 437 emit_par((Cell) MkAtomTerm(a)); 438 } 439 emit_inst(_write_call); 440 break; 441 case is_op: 442 emit_inst(_is_call); 443 break; 444 case equal_op: 445 emit_inst(_equal_call); 446 break; 447 448 case either_op: 449 emit_inst(_either_op); 450 emit_par(ppc->new1); 451 emit_upar((Cell) Code_Start+ (Cell) labels[ppc->new4]); 452 break; 453 case orelse_op: 454 emit_inst(_orelse_op); 455 emit_upar((Cell) Code_Start+ (Cell) labels[ppc->new4]); 456 break; 457 case orlast_op: 458 emit_inst(_orlast_op); 459 break; 460 461 case create_first_box_op: 462 case create_box_op: 463 case create_last_box_op: 464 emit_upar((Cell) Code_Start+ (Cell) labels[ppc->new4]); 465 alloc_found=1; 466 break; 467 468 case remove_box_op: 469 case remove_last_box_op: 470 break; 471 472 case jump_op: 473 emit_inst(_jump_op); 474 emit_upar((Cell) Code_Start+ (Cell) labels[ppc->new4]); 475 break; 476 case label_op: 477 if (pass==0) labels[ppc->new4] = get_addr(); 478 break; 479 480 case run_op: 481 /* se ficar vazio, retirar no eam_am.c o +5 das linhas pc=clause->code+5 no only_1_clause e no call */ 482 emit_inst(_try_me_op); 483 emit_par(0); 484 emit_par(0); 485 emit_par(0); 486 emit_par(0); 487 break; 488 489 case only_1_clause_op: 490 emit_inst(_only_1_clause_op); 491 emit_par(ppc->new4); 492 emit_par(((struct Clauses *)ppc->new4)->predi->arity); 493 emit_par(((struct Clauses *)ppc->new4)->nr_vars); 494 emit_par(0); /* Nr da alternativa */ 495 break; 496 case try_me_op: 497 emit_inst(_try_me_op); 498 emit_par(ppc->new4); 499 emit_par(((struct Clauses *)ppc->new4)->predi->arity); 500 emit_par(((struct Clauses *)ppc->new4)->nr_vars); 501 emit_par(0); /* Nr da alternativa */ 502 break; 503 case retry_me_op: 504 emit_inst(_retry_me_op); 505 emit_par(ppc->new4); 506 emit_par(((struct Clauses *)ppc->new4)->predi->arity); 507 emit_par(((struct Clauses *)ppc->new4)->nr_vars); 508 emit_par(ppc->new1); 509 break; 510 case trust_me_op: 511 emit_inst(_trust_me_op); 512 emit_par(ppc->new4); 513 emit_par(((struct Clauses *)ppc->new4)->predi->arity); 514 emit_par(((struct Clauses *)ppc->new4)->nr_vars); 515 emit_par(ppc->new1); 516 break; 517 518 case body_op: 519 if (next_not_nop_inst(ppc->nextInst)==procceed_op) { 520 //emit_inst(_proceed_op); 521 break; 522 } else if (next_not_nop_inst(ppc->nextInst)==fail_op) { 523 //emit_inst(_fail_op); 524 break; 525 } 526 if (ppc->new4!=0) { 527 emit_inst(_prepare_calls); 528 emit_par(ppc->new4); /* nr_calls */ 529 } 530 body=1; 531 break; 532 533 case prepare_tries: 534 emit_inst(_prepare_tries); 535 emit_par(ppc->new1); 536 emit_par(ppc->new4); 537 break; 538 539 case exit_op: 540 emit_inst(_exit_eam); 541 break; 542 543 case mark_initialised_pvars_op: 544 break; 545 case fetch_args_for_bccall: 546 case bccall_op: 547 printf("[ Fatal Error: fetch and bccall instructions not supported ]\n"); 548 exit(1); 549 break; 550 551 case endgoal_op: 552 case nop_op: 553 case name_op: 554 break; 555 556 default: 557 if (pass) { 558 printf("[ Sorry, there is at least one unsupported instruction in your code... %3d] %d\n",ppc->op,exit_op); 559 printf("[ please note that beam still does not support a lot of builtins ]\n"); 560 } 561 emit_inst(_fail_op); 562 563 } 564 ppc = ppc->nextInst; 565 } 566 emit_inst(_exit_eam); 567 emit_par(-1); 568 } 569 570 eam_assemble(CInstr * code)571Cell *eam_assemble(CInstr *code) 572 { 573 574 Code_Start=0; 575 pass=0; 576 inst_code=0; 577 eam_pass(code); 578 579 pass=1; 580 Code_Start=alloc_mem((Cell) inst_code); 581 inst_code=Code_Start; 582 eam_pass(code); 583 584 return(Code_Start); 585 } 586 587 588 #endif /* BEAM */ 589