1/* BEGIN LICENSE BLOCK 2 * Version: CMPL 1.1 3 * 4 * The contents of this file are subject to the Cisco-style Mozilla Public 5 * License Version 1.1 (the "License"); you may not use this file except 6 * in compliance with the License. You may obtain a copy of the License 7 * at www.eclipse-clp.org/license. 8 * 9 * Software distributed under the License is distributed on an "AS IS" 10 * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 11 * the License for the specific language governing rights and limitations 12 * under the License. 13 * 14 * The Original Code is The ECLiPSe Constraint Logic Programming System. 15 * The Initial Developer of the Original Code is Cisco Systems, Inc. 16 * Portions created by the Initial Developer are 17 * Copyright (C) 1989-2006 Cisco Systems, Inc. All Rights Reserved. 18 * 19 * Contributor(s): 20 * 21 * END LICENSE BLOCK */ 22 23/* 24 * ECLiPSe kernel 25 * 26 * System: ECLiPSe Constraint Logic Programming System 27 * Author/s: Rewrite 1/2000 by Joachim Schimpf, IC-Parc 28 * Version: $Id: proc_desc.c,v 1.6 2010/02/18 05:02:45 jschimpf Exp $ 29 * 30 * Contains functions to create/access/modify/remove procedure descriptors 31 * 32 * Procedure lookup: 33 * visible_procedure 34 * qualified_procedure 35 * 36 * Procedure creation and visibility declaration: 37 * local_procedure 38 * export_procedure 39 * global_procedure 40 * import_procedure 41 * reexport_procedure 42 * 43 * Changing procedure properties: 44 * pri_compatible_flags 45 * pri_change_flags 46 * pri_init_code 47 * pri_define_code 48 * pri_change_mode 49 * pri_change_prio 50 * pri_change_run_prio 51 * pri_change_trans_function 52 * Pri_Set_Reference 53 * 54 * Implementation notes: 55 * 56 * A procedure has 57 * - a descriptor in the module where it is defined (LOCAL,EXPORT), 58 * this is called the "home" or "definition" descriptor. 59 * - a descriptor in every module where it is visible (IMPORT,IMPEXP). 60 * - a qualified access descriptor (QUALI) in every module where 61 * there is a compiled qualified access to it via :/2. 62 * - a DEFAULT descriptor in every module where it is referenced but the 63 * source of the corresponding definition is not yet known. 64 * A "visibility descriptor" is a descriptor other than QUALI. 65 * To allow for incremental operation, the descriptors can be created 66 * in any order. 67 * 68 * Every descriptor has two module fields: 69 * module_def: the module to which the descriptor belongs (always set) 70 * module_ref: the module where the corresponding procedure definition 71 * can be found. For LOCAL,EXPORT this is the same as module_def, 72 * for IMPORT,IMPEXP this is the source of the import, for QUALI it 73 * is the referenced module, for DEFAULT it is D_UNKNOWN. 74 * 75 * Accesses always go via a descriptor in the module where the access 76 * happens. This is important for erasing modules: since there are no 77 * direct inter-module accesses, all descriptors in the erased module 78 * can be destroyed together with the module. 79 * 80 * Lazy import: import(Module) implements lazy import, i.e. procedures are 81 * only imported when an attempt is made to access them (visible_procedure()). 82 * Restriction: the exporting module's interface must be known at the time 83 * of import(Module), which is always the case for use_module/1. 84 * 85 * Delayed export: all exports (or globalisations) happen only when the 86 * procedure is defined (ie. acquires code). This is done to avoid problems 87 * with the incremental declaration of procedure properties - assuming that 88 * all declarations occur before the clauses, the procedure is only 89 * exported when it is fully defined. Implemented by using initially a 90 * LOCAL descriptor and change it to EXPORT later. That this needs 91 * to be done is indicated by the flag TO_EXPORT. 92 * 93 * We allow only the following incremental changes to visibility: 94 * DEFAULT -> LOCAL -> EXPORT 95 * DEFAULT -> IMPORT -> IMPEXP 96 * 97 * Reexports: we require the exported procedure to be already defined at 98 * reexportation time. That means that an IMPEXP descriptor always refers 99 * directly to the definition module. References to an IMPEXP descriptor 100 * (from an IMPORT or another IMPEXP descriptor) are always immediately 101 * forwarded to the definition module. Therefore there are no descriptor 102 * chains and the definition can always be found in one step. 103 * 104 * Parallel locks policy: 105 * ModuleLock - while a module_item is accessed 106 * ProcListLock - while a did's procedure list is traversed/modified 107 * ProcChainLock - while one of the procedure chains is traversed/modified 108*/ 109 110#include "config.h" 111#include "sepia.h" 112#include "types.h" 113#include "embed.h" 114#include "mem.h" 115#include "error.h" 116#include "opcode.h" 117#include "dict.h" 118#include "emu_export.h" 119#include "database.h" 120#include "module.h" 121#include "property.h" 122#include "gencode.h" 123 124#define a_mutex_lock(x) 125#define a_mutex_unlock(x) 126 127 128#define ExportImmediately(pd) \ 129 ((pd)->flags & CODE_DEFINED || (pd)->flags & AUTOLOAD || (pd)->trans_function) 130 131 132static int _resolve_import(dident,dident,pri**); 133static uint32 _hiding_import(dident,dident,dident*); 134static int _report_error(int, dident, dident, type); 135static void _pri_init_vmcode(pri*,int); 136void remove_procedure(pri*); 137 138 139/*---------------------------------------------------------------------- 140 * New descriptors 141 *----------------------------------------------------------------------*/ 142 143/* 144 * Allocate a new procedure descriptor 145 */ 146 147static pri* 148_new_pri(dident functor, dident module) 149{ 150 pri *pd = (pri*) hg_alloc_size(sizeof(pri)); 151 pd->did = functor; 152 pd->flags = NOREFERENCE|DEBUG_DF; 153 pd->module_def = module; 154 pd->module_ref = pd->trans_function = D_UNKNOWN; 155 pd->nextproc = pd->next_in_mod = 0; 156 pd->mode = 0; 157 pd->prio = PRIORITY_DEFAULT; 158 pd->run_prio = PRIORITY_RUN_DEFAULT; 159 pd->code.vmc = 0; 160 return pd; 161} 162 163 164/* 165 * free a procedure descriptor 166 */ 167 168static void 169_free_pri(pri *pd) 170{ 171 hg_free_size((generic_ptr)pd, sizeof(pri)); 172} 173 174 175/* 176 * Create a new descriptor and insert it into the functor and 177 * module lists as a visibility descriptor. 178 * Make sure the code field gets set after calling this! 179 * Shared memory locks: must be called with ProcListLock and ModuleLock 180 */ 181 182static pri* 183_new_visible_pri(dident functor, dident module, module_item *module_property, int visibility) 184{ 185 pri *pd = _new_pri(functor, module); 186 pd->flags |= VMCODE|ARGFIXEDWAM|visibility; 187 188 /* insert it at the beginning of the functor list */ 189 pd->nextproc = DidPtr(functor)->procedure; 190 DidPtr(functor)->procedure = pd; 191 192 /* insert it at the beginning of the module list */ 193 if (!module_property) 194 module_property = ModuleItem(module); 195 pd->next_in_mod = module_property->procedures; 196 module_property->procedures = pd; 197 198 return pd; 199} 200 201 202/*---------------------------------------------------------------------- 203 * Auxiliary functions 204 *----------------------------------------------------------------------*/ 205 206/* Get a procedure's definition (home) descriptor, if it exists. */ 207 208pri * 209pri_home(pri *pd) 210{ 211 type tm; 212 if (pd->module_ref == pd->module_def) 213 return pd; 214 if (pd->module_ref == D_UNKNOWN) 215 { 216 Set_Bip_Error(NOENTRY); 217 return 0; 218 } 219 tm.kernel = ModuleTag(pd->module_ref); 220 return visible_procedure(pd->did, pd->module_ref, tm, PRI_DONTIMPORT|PRI_EXPORTEDONLY); 221} 222 223 224/* Find the visibility descriptor for functor in module, if it exists */ 225 226static pri * 227_current_visible(dident functor, dident module) 228/* Locks: requires ProcListLock. aquires nothing. */ 229{ 230 pri *pd; 231 232 for(pd=DidPtr(functor)->procedure; IsVisibilityPri(pd); pd=pd->nextproc) 233 { 234 if (pd->module_def == module) 235 return pd; 236 } 237 return 0; 238} 239 240 241/* 242 * Find the EXPORT descriptor for functor if imported from 243 * export_module. Follow IMPEXP indirection if necessary. 244 * Return the actual exporting module in last_module, even if the 245 * export descriptor does not exist yet. 246 */ 247 248static pri * 249_find_export(dident functor, dident exporting_module, dident *last_module) 250/* Locks: requires ProcListLock. aquires nothing. */ 251{ 252 pri *pd; 253 for(pd=DidPtr(functor)->procedure; IsVisibilityPri(pd); pd=pd->nextproc) 254 { 255 if (pd->module_def == exporting_module) 256 { 257 switch (PriScope(pd)) 258 { 259 case EXPORT: 260 *last_module = exporting_module; 261 return pd; 262 case IMPEXP: 263 return _find_export(functor, pd->module_ref, last_module); 264 default: 265 *last_module = exporting_module; 266 return 0; 267 } 268 } 269 } 270 *last_module = exporting_module; 271 return 0; 272} 273 274 275static int 276_export_exists(dident functor, dident exporting_module) 277/* Locks: requires ProcListLock. aquires nothing. */ 278{ 279 dident dummy; 280 return _find_export(functor, exporting_module, &dummy) ? 1 : 0; 281} 282 283 284/* 285 * When a new IMPEXP descriptor is created, find all descriptors that point 286 * to it and forward their module_ref to the (now known) definition module. 287 */ 288static void 289_deref_chains(pri *new_impexp) /* a new IMPEXP maximally dereferenced */ 290/* Locks: requires ProcListLock. aquires nothing. */ 291{ 292 pri *pd; 293 for(pd=DidPtr(new_impexp->did)->procedure; pd; pd=pd->nextproc) 294 { 295 if (PriIsProxy(pd) && pd->module_ref == new_impexp->module_def) 296 { 297 pd->module_ref = new_impexp->module_ref; 298 } 299 } 300} 301 302 303/* 304 * Check whether a procedure is referenced, ie. whether any of 305 * its descriptors is referenced 306 */ 307 308static int 309_procedure_referenced(pri *pd) 310/* Locks: requires nothing. acquires ProcListLock. */ 311{ 312 dident definition_module; 313 314 if (PriReferenced(pd)) 315 return 1; 316 if (!PriExported(pd)) 317 return 0; 318 319 a_mutex_lock(&ProcListLock); 320 definition_module = pd->module_def; 321 for(pd = DidPtr(pd->did)->procedure; pd; pd = pd->nextproc) 322 { 323 if (pd->module_ref == definition_module && PriReferenced(pd)) 324 { 325 a_mutex_unlock(&ProcListLock); 326 return 1; 327 } 328 } 329 a_mutex_unlock(&ProcListLock); 330 return 0; 331} 332 333 334/* 335 * Add/delete a descriptor from a general-purpose descriptor chain 336 */ 337 338void 339add_proc_to_chain(pri *p, proc_duet **chain) 340/* Locks: requires ProcChainLock. aquires nothing. */ 341{ 342 proc_duet *gd; 343 344 gd = (proc_duet *) hg_alloc_size(sizeof(proc_duet)); 345 gd->desc = p; 346 gd->next = *chain; 347 *chain = gd; 348} 349 350void 351delete_proc_from_chain(pri *p, proc_duet **chain) 352/* Locks: requires ProcChainLock. aquires nothing. */ 353{ 354 proc_duet *current_gd; 355 356 current_gd = *chain; 357 while (current_gd) 358 { 359 if (current_gd->desc == p) 360 { /* found, so delete it from the chain */ 361 *chain = current_gd->next; 362 hg_free_size((generic_ptr) current_gd, sizeof(proc_duet)); 363 break; 364 } 365 chain = ¤t_gd->next; 366 current_gd = current_gd->next; 367 } 368} 369 370 371/* 372 * Report an error like: 373 * <error message> in arg1/arity in module 374 */ 375 376static int 377_report_error(int err, 378 dident arg1, /* any arity */ 379 dident module, /* arity 0 */ 380 type mod_tag) 381{ 382 int res; 383 pword *old_tg = TG; 384 pword *tg = TG; 385 pword mod, goal; 386 387 Make_Struct(&goal, TG); 388 389 Push_Struct_Frame(d_.syserror); ++tg; 390 Make_Integer(tg, -err); ++tg; 391 Make_Struct(tg, TG); ++tg; 392 tg->val.did = module; 393 tg++->tag.all = mod_tag.all; 394 tg->val.did = module; 395 tg++->tag.all = mod_tag.all; 396 397 Push_Struct_Frame(d_.quotient); ++tg; 398 Make_Atom(tg, add_dict(arg1,0)); ++tg; 399 Make_Integer(tg, DidArity(arg1)); 400 401 mod.val.did = d_.kernel_sepia; 402 mod.tag.kernel = ModuleTag(d_.kernel_sepia); 403 res = query_emulc(goal.val, goal.tag, mod.val, mod.tag); 404 TG = old_tg; 405 return res; 406} 407 408 409#ifdef PRINTAM 410 411/* 412 * Debugging support: print procedure descriptors 413 */ 414 415void 416print_pri(pri *pd) 417{ 418 switch(PriScope(pd)) 419 { 420 case QUALI: p_fprintf(current_output_, "QUALI "); break; 421 case LOCAL: p_fprintf(current_output_, "LOCAL "); break; 422 case EXPORT: p_fprintf(current_output_, "EXPORT "); break; 423 case IMPORT: p_fprintf(current_output_, "IMPORT "); break; 424 case DEFAULT: p_fprintf(current_output_, "DEFAUL "); break; 425 case IMPEXP: p_fprintf(current_output_, "IMPEXP "); break; 426 default: p_fprintf(current_output_, "?????? "); break; 427 } 428 p_fprintf(current_output_, "in %12s from %12s", 429 DidName(pd->module_def), 430 pd->module_ref? DidName(pd->module_ref) : "UNKNOWN"); 431 432 p_fprintf(current_output_, " %c%c%c %c %c%c%c%c%c %c%c%c%c%c %c%c%c %01x p%d", 433 pd->flags&SYSTEM ? 'S' : '_', 434 pd->flags&NOREFERENCE ? 'N' : '_', 435 pd->flags&CODE_DEFINED ? 'C' : '_', 436 437 pd->flags&TO_EXPORT ? 'X' : '_', 438 439 pd->flags&PROC_PARALLEL ? 'P' : '_', 440 pd->flags&PROC_DEMON ? 'D' : '_', 441 pd->flags&TOOL ? 'T' : '_', 442 pd->flags&AUTOLOAD ? 'A' : '_', 443 pd->flags&PROC_DYNAMIC ? 'Y' : '_', 444 445 pd->flags&DEBUG_TR ? 'T' : '_', 446 pd->flags&DEBUG_SP ? 'P' : '_', 447 pd->flags&DEBUG_SK ? 'K' : '_', 448 pd->flags&DEBUG_DB ? 'D' : '_', 449 pd->flags&DEBUG_ST ? 'S' : '_', 450 451 (pd->flags&(CODETYPE)) == VMCODE ? 'v' : 'f', 452 (pd->flags&(ARGPASSING)) == ARGFIXEDWAM ? 'a' : 453 (pd->flags&(ARGPASSING)) == ARGFLEXWAM ? 'f' : '?', 454 pd->flags&EXTERN ? 'X' : '_', 455 456 pd->flags&(UNIFTYPE), 457 PriPriority(pd)); 458 459 if (!PriCode(pd)) 460 p_fprintf(current_output_, " null_code"); 461 else if ((PriCodeType(pd) == VMCODE) && IsUndefined(PriCode(pd))) 462 p_fprintf(current_output_, " undef_code"); 463 else 464 p_fprintf(current_output_, " 0x%x", PriCode(pd)); 465 466 ec_newline(current_output_); 467} 468 469void 470print_procs(char *name, int arity) 471{ 472 dident d = enter_dict(name, arity); 473 if (d == D_UNKNOWN) 474 { 475 p_fprintf(current_output_,"No such did"); 476 ec_newline(current_output_); 477 } 478 else if (! d->procedure) 479 { 480 p_fprintf(current_output_,"No procedures"); 481 ec_newline(current_output_); 482 } 483 else 484 { 485 pri *pd; 486 for (pd=d->procedure; pd; pd=pd->nextproc) 487 print_pri(pd); 488 } 489} 490 491void 492pri_statistics(void) 493{ 494 int idx = 0; 495 dident mod; 496 int count[6]; 497 498 while (next_functor(&idx, &mod)) 499 { 500 if (IsModule(mod)) 501 { 502 pri *pd; 503 int i; 504 for(i=0;i<6;++i) count[i] = 0; 505 506 for (pd = ModuleItem(mod)->procedures; pd; pd = pd->next_in_mod) 507 { 508 switch(PriScope(pd)) 509 { 510 case QUALI: ++count[0]; break; 511 case LOCAL: ++count[1]; break; 512 case EXPORT: ++count[2]; break; 513 case IMPORT: ++count[3]; break; 514 case DEFAULT: ++count[4]; break; 515 case IMPEXP: ++count[5]; break; 516 default: p_fprintf(current_err_, "Illegal scope %s\n", PriScope(pd)); break; 517 } 518 } 519 p_fprintf(log_output_, "\nModule: %s\n", DidName(mod)); 520 p_fprintf(log_output_, " QUALI=%d", count[0]); 521 p_fprintf(log_output_, " LOCAL=%d", count[1]); 522 p_fprintf(log_output_, " EXPORT=%d", count[2]); 523 p_fprintf(log_output_, " IMPORT=%d", count[3]); 524 p_fprintf(log_output_, " DEFAULT=%d", count[4]); 525 p_fprintf(log_output_, " IMPEXP=%d", count[5]); 526 ec_newline(log_output_); 527 } 528 } 529} 530#endif 531 532 533/*---------------------------------------------------------------------- 534 * Comparing and updating two descriptors 535 *----------------------------------------------------------------------*/ 536 537/* 538 * A shadow descriptor is a descriptor whose properties are just copies 539 * of the corresponding home descriptor. It can't be changed independently. 540 */ 541#define ShadowDescriptor(pd) \ 542 (PriScope(pd) == IMPEXP || \ 543 (PriScope(pd) == IMPORT || PriScope(pd) == QUALI) \ 544 && _export_exists(pd->did, pd->module_ref)) 545 546 547/* 548 * Used to check compatibility before linking a definition to a use 549 * (e.g. on actual import) 550 */ 551 552static int 553_compatible_def_use(pri *def, pri *use) 554{ 555 uint32 conflicts; 556 char *reason = NULL; 557 558 /* if not yet referenced, any change is allowed */ 559 if (!PriReferenced(use)) 560 return 1; 561 562 /* don't allow changing certain flags */ 563 conflicts = (def->flags ^ use->flags) & 564 (use->flags & CODE_DEFINED ? 565 PF_DONT_CHANGE_WHEN_DEFINED : 566 PF_DONT_CHANGE_WHEN_REFERENCED); 567 568 if (conflicts) 569 { 570 if (conflicts & TOOL) 571 reason = "tool declaration"; 572 else if (conflicts & PROC_DYNAMIC) 573 reason = "static/dynamic"; 574 else if (conflicts & PROC_DEMON) 575 reason = "demon declaration"; 576 else if (conflicts & PROC_PARALLEL) 577 reason = "parallel declaration"; 578 else if (conflicts & (CODETYPE|ARGPASSING|UNIFTYPE)) 579 reason = "calling convention"; 580 else 581 reason = "predicate properties"; 582 } 583 584 /* other restrictions when already referenced */ 585 if (def->mode != use->mode) 586 reason = "mode declaration"; 587 588 if (def->trans_function != use->trans_function) 589 reason = "inline declaration"; 590 591 if (reason) 592 { 593 p_fprintf(warning_output_, 594 "Definition of %s/%d in module %s is incompatible (%s) with call in module %s\n", 595 DidName(def->did), DidArity(def->did), DidName(def->module_def), 596 reason, DidName(use->module_def)); 597 ec_flush(warning_output_); 598 return 0; 599 } 600 601 return 1; 602} 603 604 605/* 606 * Copy contents of a definition descriptor to a use (shadow) descriptor. 607 * It is assumed that compatibility checks have already been done. 608 */ 609 610static void 611_update_def_use(pri *def, pri *use) 612{ 613 /* Note on memory management of code blocks: 614 * Undefined-code blocks are never shared between descriptors, 615 * so don't copy pointers to them. 616 * Defined-code is shared and pointed to from all descriptors. 617 */ 618 if ((PriCodeType(use) == VMCODE) && !(PriFlags(use) & CODE_DEFINED)) 619 { 620 if (PriFlags(def) & CODE_DEFINED) 621 { 622 remove_procedure(use); /* undefined -> defined */ 623 use->code = def->code; 624 } 625 else if (!use->code.vmc) /* undefined -> undefined */ 626 _pri_init_vmcode(use, PriFlags(def)&TOOL); 627 /* else keep undefined-code field */ 628 } 629 else 630 { 631 if ((PriCodeType(def) == VMCODE) && !(PriFlags(def) & CODE_DEFINED)) 632 _pri_init_vmcode(use, PriFlags(def)&TOOL); /* defined -> undefined */ 633 else 634 use->code = def->code; /* defined -> defined */ 635 } 636 use->module_ref = def->module_def; 637 use->mode = def->mode; 638 use->prio = def->prio; 639 use->run_prio = def->run_prio; 640 use->trans_function = def->trans_function; 641 use->flags = (use->flags & DESCRIPTOR_FLAGS) | (def->flags & COMMON_FLAGS); 642} 643 644 645/* 646 * Given the home module descriptor of a procedure, 647 * update all its uses (import/quali/impexp). 648 * It is assumed that compatibility checks have already been done. 649 */ 650 651static void 652_update_all_uses(pri *def) /* must be the definition module descriptor */ 653/* Locks: requires ProcListLock. acquires nothing. */ 654{ 655 pri *use; 656 657 if (!PriExported(def)) 658 return; 659 660 for(use = DidPtr(PriDid(def))->procedure; use; use = use->nextproc) 661 { 662 if (PriIsProxy(use) && use->module_ref == def->module_ref) 663 { 664 _update_def_use(def, use); 665 } 666 } 667} 668 669 670/* 671 * In preparation of _update_all_uses(), remove uses (import/quali/impexp) 672 * that are incompatible with the definition. 673 */ 674 675static void 676_remove_incompatible_uses(pri *def) /* must be the definition module descriptor */ 677/* Locks: requires ProcListLock. acquires nothing. */ 678{ 679 pri *use; 680 681 if (!PriExported(def)) 682 return ; 683 684 for(use = DidPtr(PriDid(def))->procedure; use; use = use->nextproc) 685 { 686 if (PriIsProxy(use) && use->module_ref == def->module_ref) 687 { 688 if (!_compatible_def_use(def, use)) 689 { 690 /* attempt to undo the impossible def-use link */ 691 switch (PriScope(use)) 692 { 693 case IMPORT: Pri_Set_Scope(use, LOCAL); break; 694 case IMPEXP: Pri_Set_Scope(use, EXPORT); break; 695 case QUALI: break; 696 } 697 use->module_ref = use->module_def; 698 } 699 } 700 } 701} 702 703 704/* Perform delayed export/globalisation of a procedure if necessary */ 705 706static void 707_delayed_export(pri *pd) 708{ 709 if (pd->flags & TO_EXPORT) /* delayed export */ 710 { 711 Pri_Set_Scope(pd, EXPORT); 712 pd->flags &= ~TO_EXPORT; 713 _remove_incompatible_uses(pd); 714 } 715} 716 717/*---------------------------------------------------------------------- 718 * Changing fields in the desciptor 719 *----------------------------------------------------------------------*/ 720 721/* 722 * Check whether the flags specified by 'mask' can be set to the 'new' values. 723 * All COMMON_FLAGS can be checked that way, including CODE_TYPE. 724 */ 725 726int 727pri_compatible_flags(pri *pd, uint32 mask, uint32 new) 728{ 729 uint32 illegal_change; 730 731 if (ShadowDescriptor(pd)) 732 ; /* allow no changes at all */ 733 else if (pd->flags & CODE_DEFINED) 734 mask &= PF_DONT_CHANGE_WHEN_DEFINED; 735 else if (_procedure_referenced(pd)) 736 mask &= PF_DONT_CHANGE_WHEN_REFERENCED; 737 else 738 return PSUCCEED; 739 740 new &= mask; 741 illegal_change = (pd->flags ^ new) & mask; 742 if (illegal_change) 743 { 744 /* make a more precise error message */ 745 if (illegal_change & SYSTEM) 746 return REDEF_SYS; 747 if (illegal_change & TOOL) 748 return TOOL_REDEF; 749 return INCONSISTENCY; 750 } 751 return PSUCCEED; 752} 753 754 755/* 756 * Set the flags specified by 'mask' to the 'new' values. 757 * Use pri_compatible_flags() beforehand to check whether this is allowed! 758 * The flags that can be changed using this procedure are the 759 * COMMON_FLAGS except CODETYPE 760 * (CODETYPE is managed by pri_init_code() and pri_define_code()) 761 */ 762 763void 764pri_change_flags(pri *pd, uint32 mask, uint32 new) 765{ 766 /* do the change in the home descriptor, then distribute it */ 767 pd->flags = (pd->flags & ~mask) | (new & mask); 768 if (new & AUTOLOAD) 769 _delayed_export(pd); 770 _update_all_uses(pd); 771} 772 773 774/* 775 * Construct the default code for an undefined procedure. 776 * (this should probably go elsewhere) 777 */ 778#define UNDEF_CODE_SIZE 3 779 780static vmcode * 781_undef_code(pri *pd) 782{ 783 vmcode *code, *start; 784 code = (vmcode *) hg_alloc_size(sizeof(vmcode) * (UNDEF_CODE_SIZE + PROC_PREFIX_SIZE)); 785 /* Make_Procedure_Prefix(link, size, bid, fid, lid, cid, did) */ 786 Make_Procedure_Prefix(0L, UNDEF_CODE_SIZE, (uword)-1, D_UNKNOWN, UNDEFINED_PROC, (uword)-1, PriDid(pd)); 787 start = code; 788 Store_2(Undefined, pd); 789 Store_i(Code_end); 790 return start; 791} 792 793 794/* 795 * _pri_init_vmcode(), _pri_clear_code() 796 * auxiliary functions to set the procedure code field 797 */ 798 799static void 800_pri_init_vmcode(pri *pd, int tool_flag) /* hopefully a temporary hack... */ 801{ 802 pd->code.vmc = _undef_code(pd); 803 pd->flags &= ~CODE_DEFINED; 804 /* this is important for saving the arguments in the event mechanism */ 805 if (tool_flag) 806 { Incr_Code_Arity(pd->code.vmc); } 807} 808 809static void 810_pri_clear_code(pri *pd) 811{ 812 if (pd->flags & CODE_DEFINED) 813 if (pd->module_def == pd->module_ref) 814 remove_procedure(pd); /* sets code to 0 */ 815 else 816 pd->code.vmc = 0; /* just a copy of the code field! */ 817 else 818 remove_procedure(pd); /* sets code to 0 */ 819} 820 821 822/* 823 * pri_init_code() and pri_define_code() are used to change the code field 824 * (together with the CODE_TYPE and the CODE_DEFINED flags). 825 * Make sure beforehand (by calling pri_compatible_flags()) 826 * that changing to code_type is allowed. 827 */ 828void 829pri_init_code(pri *pd, /* any descriptor */ 830 int code_type) 831{ 832 if (pd->code.vmc) /* free old code */ 833 { 834 remove_procedure(pd); 835 } 836 pd->flags = (pd->flags & ~(CODETYPE|CODE_DEFINED)) | code_type; 837 /* do the change in the home descriptor, then distribute it */ 838 if (code_type == VMCODE) 839 _pri_init_vmcode(pd, PriFlags(pd)&TOOL); 840 else 841 pd->code.cint = 0; 842 _update_all_uses(pd); 843} 844 845void 846pri_define_code(pri *pd, /* home descriptor only!!! */ 847 int code_type, 848 pri_code_t new_code) 849{ 850 if (pd->code.vmc) /* free old code */ 851 { 852 remove_procedure(pd); 853 } 854 /* do the change in the home descriptor first */ 855 pd->flags = (pd->flags & ~CODETYPE) | code_type | CODE_DEFINED; 856 pd->code = new_code; 857 /* remove incompatible uses, then update the others */ 858 _delayed_export(pd); 859 _update_all_uses(pd); 860} 861 862 863/* Change a procedure's mode field */ 864 865int 866pri_change_mode(pri *pd, /* any descriptor */ 867 uint32 new_mode) 868{ 869 if (ShadowDescriptor(pd)) 870 { 871 /* allow no changes */ 872 return pd->mode == new_mode ? PSUCCEED : ACCESSING_NON_LOCAL; 873 } 874 pd->mode = new_mode; 875 _update_all_uses(pd); 876 return PSUCCEED; 877} 878 879 880/* Change a procedure's priorities */ 881 882int 883pri_change_prio(pri *pd, int new_prio) 884{ 885 if (ShadowDescriptor(pd)) 886 { 887 /* allow no changes */ 888 return pd->prio == new_prio ? PSUCCEED : ACCESSING_NON_LOCAL; 889 } 890 pd->prio = new_prio; 891 _update_all_uses(pd); 892 return PSUCCEED; 893} 894 895int 896pri_change_run_prio(pri *pd, int new_prio) 897{ 898 if (ShadowDescriptor(pd)) 899 { 900 /* allow no changes */ 901 return pd->run_prio == new_prio ? PSUCCEED : ACCESSING_NON_LOCAL; 902 } 903 pd->run_prio = new_prio; 904 _update_all_uses(pd); 905 return PSUCCEED; 906} 907 908 909/* Change a procedure's inline (goal transformation) field */ 910 911int 912pri_change_trans_function(pri *pd, /* any descriptor */ 913 dident trans_function) 914{ 915 if (ShadowDescriptor(pd)) 916 { 917 /* allow no changes */ 918 return pd->trans_function == trans_function ? PSUCCEED : ACCESSING_NON_LOCAL; 919 } 920 pd->trans_function = trans_function; 921 _delayed_export(pd); 922 _update_all_uses(pd); 923 return PSUCCEED; 924} 925 926 927/*---------------------------------------------------------------------- 928 * Find or create a local procedure in the given module. 929 * 930 * Possible options: 931 * PRI_CREATE create the procedure if it doesn't exist 932 * 933 * We allow 934 * null -> LOCAL (if PRI_CREATE) 935 * DEFAULT -> LOCAL (if PRI_CREATE) 936 * LOCAL -> LOCAL 937 * EXPORT -> EXPORT 938 * Error 939 * IMPORT -> error 940 * 941 * Shared memory locks: ProcListLock, ModuleLock 942 *----------------------------------------------------------------------*/ 943 944pri * 945local_procedure(dident functor, dident module, type module_tag, int options) 946{ 947 pri *pd; 948 949 if (UnauthorizedAccess(module, module_tag)) 950 { 951 Set_Bip_Error(LOCKED); 952 return 0; 953 } 954 a_mutex_lock(&ProcListLock); 955 pd = _current_visible(functor, module); 956 if (pd) 957 { 958 switch(PriScope(pd)) 959 { 960 case DEFAULT: 961 if (options & PRI_CREATE) 962 { 963 Pri_Set_Scope(pd, LOCAL); 964 pd->module_ref = module; 965 } 966 else 967 { 968 Set_Bip_Error(NOENTRY); 969 pd = 0; 970 } 971 break; 972 973 case IMPORT: 974 case IMPEXP: 975 Set_Bip_Error(options & PRI_CREATE? IMPORT_EXISTS:ACCESSING_NON_LOCAL); 976 pd = 0; 977 break; 978 979 case LOCAL: 980 case EXPORT: 981 break; 982 } 983 } 984 else if (options & PRI_CREATE) 985 { 986 if (!(options & PRI_DONTWARN)) 987 { 988 dident exporting_module; 989 switch (_hiding_import(functor, module, &exporting_module)) 990 { 991 case IMPORT: 992 p_fprintf(warning_output_, 993 "WARNING: Hiding imported predicate %s/%d from module %s in module %s (use local/1)\n", 994 DidName(functor), DidArity(functor), 995 DidName(exporting_module), DidName(module)); 996 ec_flush(warning_output_); 997 break; 998 case SYSTEM: 999 a_mutex_unlock(&ProcListLock); 1000 Set_Bip_Error(BUILT_IN_REDEF); 1001 return 0; 1002 } 1003 } 1004 a_mutex_lock(&ModuleLock); 1005 pd = _new_visible_pri(functor, module, 0, LOCAL); 1006 a_mutex_unlock(&ModuleLock); 1007 _pri_init_vmcode(pd, 0); 1008 pd->module_ref = module; 1009 } 1010 else 1011 { 1012 Set_Bip_Error(NOENTRY); 1013 } 1014 a_mutex_unlock(&ProcListLock); 1015 return pd; 1016} 1017 1018 1019/*---------------------------------------------------------------------- 1020 * Export a procedure, create if it doesn't exist 1021 * 1022 * We allow 1023 * null -> DEFAULT -> EXPORT 1024 * DEFAULT -> EXPORT 1025 * LOCAL -> EXPORT 1026 * EXPORT -> EXPORT 1027 * Error 1028 * IMPORT -> error 1029 * IMPEXP -> error 1030 * 1031 * Shared memory locks: like visible_procedure() 1032 *----------------------------------------------------------------------*/ 1033 1034 1035pri * 1036export_procedure(dident functor, dident module, type module_tag) 1037{ 1038 pri *pd; 1039 1040 if (UnauthorizedAccess(module, module_tag)) 1041 { 1042 Set_Bip_Error(LOCKED); 1043 return 0; 1044 } 1045 a_mutex_lock(&ProcListLock); 1046 pd = _current_visible(functor, module); 1047 if (!pd) 1048 { 1049 a_mutex_lock(&ModuleLock); 1050 pd = _new_visible_pri(functor, module, 0, DEFAULT); 1051 a_mutex_unlock(&ModuleLock); 1052 _pri_init_vmcode(pd, 0); 1053 } 1054 switch(PriScope(pd)) 1055 { 1056 case DEFAULT: 1057 Pri_Set_Scope(pd, LOCAL); 1058 pd->module_ref = module; 1059 /* fall through */ 1060 1061 case LOCAL: 1062 if (ExportImmediately(pd)) 1063 { 1064 pd->flags &= ~TO_EXPORT; 1065 Pri_Set_Scope(pd, EXPORT); 1066 _remove_incompatible_uses(pd); 1067 _update_all_uses(pd); 1068 } 1069 else 1070 { 1071 pd->flags |= TO_EXPORT; 1072 /* checking/linking against imports is done later 1073 * (end of module interface or code definition) */ 1074 } 1075 break; 1076 1077 case IMPORT: 1078 Set_Bip_Error(IMPORT_EXISTS); pd = 0; break; 1079 1080 case IMPEXP: 1081 Set_Bip_Error(REEXPORT_EXISTS); pd = 0; break; 1082 1083 case EXPORT: 1084 break; 1085 } 1086 a_mutex_unlock(&ProcListLock); 1087 return pd; 1088} 1089 1090 1091/*---------------------------------------------------------------------- 1092 * Globalise a procedure - similar to exporting 1093 *----------------------------------------------------------------------*/ 1094 1095pri * 1096global_procedure(dident functor, dident module, type module_tag) 1097{ 1098 return export_procedure(functor, module, module_tag); 1099} 1100 1101 1102#if 0 1103/* 1104 * Perform all delayed export/global declarations in module mod 1105 * - mark export descriptor 1106 * - check compatibility and update import descriptors 1107 */ 1108 1109void 1110check_def_use_module_interface(dident mod, type mod_tag) 1111/* Locks: aquires ProcListLock, ModuleLock. */ 1112{ 1113 pri *def; 1114 1115 a_mutex_lock(&ModuleLock); 1116 a_mutex_lock(&ProcListLock); 1117 for (def = ModuleItem(mod)->procedures; def; def = def->next_in_mod) 1118 { 1119 if (PriScope(def) == LOCAL && PriFlags(def) & TO_EXPORT) 1120 { 1121 _delayed_export(def); 1122 _remove_incompatible_uses(def); 1123 _update_all_uses(def); 1124 } 1125 } 1126 a_mutex_unlock(&ProcListLock); 1127 a_mutex_unlock(&ModuleLock); 1128} 1129#endif 1130 1131 1132/*---------------------------------------------------------------------- 1133 * Import a procedure 1134 * 1135 * We allow 1136 * null -> DEFAULT -> IMPORT 1137 * DEFAULT -> IMPORT 1138 * IMPORT -> IMPORT (same exporter) 1139 * IMPEXP -> IMPEXP (same exporter) 1140 * Error 1141 * LOCAL -> error 1142 * EXPORT -> error 1143 * IMPORT -> error if different exporter 1144 * 1145 * Shared memory locks: like visible_procedure() 1146 *----------------------------------------------------------------------*/ 1147 1148pri * 1149import_procedure(dident functor, dident module, type module_tag, dident exporting_module) 1150{ 1151 pri *pd, *exported_pd; 1152 1153 if (UnauthorizedAccess(module, module_tag)) 1154 { 1155 Set_Bip_Error(LOCKED); 1156 return 0; 1157 } 1158 a_mutex_lock(&ProcListLock); 1159 pd = _current_visible(functor, module); 1160 if (!pd) 1161 { 1162 a_mutex_lock(&ModuleLock); 1163 pd = _new_visible_pri(functor, module, 0, DEFAULT); 1164 a_mutex_unlock(&ModuleLock); 1165 _pri_init_vmcode(pd, 0); 1166 } 1167 exported_pd = _find_export(functor, exporting_module, &exporting_module); 1168 switch(PriScope(pd)) 1169 { 1170 case DEFAULT: 1171 if (exported_pd) 1172 { 1173 if (_compatible_def_use(exported_pd, pd)) 1174 { 1175 _update_def_use(exported_pd, pd); 1176 } 1177 else 1178 { 1179 Set_Bip_Error(INCONSISTENCY); 1180 pd = 0; 1181 break; 1182 } 1183 Pri_Set_Scope(pd, IMPORT); 1184 pd->module_ref = exported_pd->module_def; 1185 } 1186 else /* else chain is not yet completely known */ 1187 { 1188 Pri_Set_Scope(pd, IMPORT); 1189 pd->module_ref = exporting_module; 1190 } 1191 break; 1192 case IMPORT: 1193 case IMPEXP: 1194 if (pd->module_ref != exporting_module) 1195 { 1196 Set_Bip_Error(IMPORT_EXISTS); 1197 pd = 0; 1198 } 1199 /* else ALREADY_IMPORT */ 1200 break; 1201 case LOCAL : 1202 if (pd->module_ref != exporting_module) 1203 { 1204 Set_Bip_Error(LOCAL_EXISTS); pd = 0; 1205 } 1206 break; 1207 case EXPORT : 1208 if (pd->module_ref != exporting_module) 1209 { 1210 Set_Bip_Error(EXPORT_EXISTS); pd = 0; 1211 } 1212 break; 1213 } 1214 a_mutex_unlock(&ProcListLock); 1215 return pd; 1216} 1217 1218 1219/*---------------------------------------------------------------------- 1220 * Reexport a procedure 1221 * As opposed to importing, this requires the export descriptor to 1222 * exist already. 1223 * 1224 * We allow 1225 * null -> DEFAULT -> IMPEXP 1226 * DEFAULT -> IMPEXP 1227 * IMPORT -> IMPEXP (same exporter) 1228 * IMPEXP -> IMPEXP (same exporter) 1229 * Error 1230 * LOCAL -> error 1231 * EXPORT -> error 1232 * IMPORT -> error if different exporter 1233 * IMPEXP -> error if different exporter 1234 * 1235 * Shared memory locks: like visible_procedure() 1236 *----------------------------------------------------------------------*/ 1237 1238pri * 1239reexport_procedure(dident functor, dident module, type module_tag, dident from_module) 1240{ 1241 pri *pd, *exported_pd; 1242 1243 if (UnauthorizedAccess(module, module_tag)) 1244 { 1245 Set_Bip_Error(LOCKED); 1246 return 0; 1247 } 1248 a_mutex_lock(&ProcListLock); 1249 pd = _current_visible(functor, module); 1250 if (!pd) 1251 { 1252 a_mutex_lock(&ModuleLock); 1253 pd = _new_visible_pri(functor, module, 0, DEFAULT); 1254 a_mutex_unlock(&ModuleLock); 1255 _pri_init_vmcode(pd, 0); 1256 } 1257 exported_pd = _find_export(functor, from_module, &from_module); 1258 switch(PriScope(pd)) 1259 { 1260 case DEFAULT: 1261 if (exported_pd) 1262 { 1263 if (_compatible_def_use(exported_pd, pd)) 1264 { 1265 _update_def_use(exported_pd, pd); 1266 } 1267 else 1268 { 1269 Set_Bip_Error(INCONSISTENCY); 1270 pd = 0; 1271 break; 1272 } 1273 Pri_Set_Scope(pd, IMPEXP); 1274 pd->module_ref = from_module; 1275 _deref_chains(pd); /* because IMPEXP */ 1276 _remove_incompatible_uses(exported_pd); /* because EXPORT */ 1277 _update_all_uses(exported_pd); /* because EXPORT */ 1278 } 1279 else /* else chain is not yet completely known */ 1280 { 1281 Set_Bip_Error(NOENTRY); 1282 pd =0; 1283 } 1284 break; 1285 case IMPORT: 1286 if (exported_pd && pd->module_ref == from_module) 1287 { 1288 Pri_Set_Scope(pd, IMPEXP); 1289 _deref_chains(pd); /* because IMPEXP */ 1290 _remove_incompatible_uses(exported_pd); /* because EXPORT */ 1291 _update_all_uses(exported_pd); /* because EXPORT */ 1292 } 1293 else /* else chain is not yet completely known */ 1294 { 1295 Set_Bip_Error(NOENTRY); 1296 pd =0; 1297 } 1298 break; 1299 case IMPEXP: 1300 if (pd->module_ref != from_module) 1301 { 1302 Set_Bip_Error(REEXPORT_EXISTS); 1303 pd = 0; 1304 } 1305 /* else ALREADY_REEXPORT */ 1306 break; 1307 case LOCAL : 1308 Set_Bip_Error(LOCAL_EXISTS); pd = 0; break; 1309 case EXPORT : 1310 Set_Bip_Error(EXPORT_EXISTS); pd = 0; break; 1311 } 1312 a_mutex_unlock(&ProcListLock); 1313 return pd; 1314} 1315 1316 1317/*---------------------------------------------------------------------- 1318 * Find or create the visible descriptor. 1319 * This is used for accessing properties or the code of the procedure. 1320 * We allow: 1321 * null,DEFAULT -> resolve imports successfully -> IMPORT 1322 * null,DEFAULT -> resolve imports unsuccessfully -> null 1323 * null,DEFAULT -> resolve imports unsuccessfully -> DEFAULT (if PRI_CREATE) 1324 * null,DEFAULT -> resolve imports with error -> null 1325 * LOCAL -> LOCAL 1326 * EXPORT -> EXPORT 1327 * IMPORT -> IMPORT 1328 * 1329 * Locked modules: only allow the exports to be accessed. 1330 * 1331 * 1332 * Possible options 1333 * PRI_CREATE create descriptor if none (forward references) 1334 * PRI_REFER set descriptor's referenced-flag 1335 * PRI_DONTIMPORT don't try to resolve imports 1336 * PRI_EXPORTEDONLY access only exported predicates 1337 * PRI_DONTWARN don't raise IMPORT_CLASH on ambiguous import, 1338 * simply return NOENTRY 1339 * 1340 * Possible error codes (if returned pri* is null): 1341 * NOENTRY unless PRI_CREATE options set 1342 * LOCKED 1343 * CONSISTENCY 1344 * 1345 * Shared memory locks: Acquires ProcListLock and possibly ModuleLock 1346 *----------------------------------------------------------------------*/ 1347 1348#define UnauthorizedAccessOption(module, module_tag, exponly) \ 1349 (!IsModuleTag(module, module_tag) && ((exponly) || IsLocked(module))) 1350 1351pri * 1352visible_procedure(dident functor, dident module, type module_tag, int options) 1353{ 1354 int res; 1355 pri *pd; 1356 1357 a_mutex_lock(&ProcListLock); 1358 pd = _current_visible(functor, module); 1359 if (pd) 1360 { 1361 switch(PriScope(pd)) 1362 { 1363 case LOCAL: 1364 case IMPORT: 1365 if (UnauthorizedAccessOption(module, module_tag, options & PRI_EXPORTEDONLY)) 1366 { 1367 a_mutex_unlock(&ProcListLock); 1368 Set_Bip_Error(options & PRI_EXPORTEDONLY? NOENTRY: LOCKED); 1369 return 0; 1370 } 1371 /* fall through */ 1372 case EXPORT: 1373 case IMPEXP: 1374 if (options & PRI_REFER) 1375 { 1376 Pri_Set_Reference(pd); 1377 } 1378 a_mutex_unlock(&ProcListLock); 1379 return pd; 1380 case DEFAULT: 1381 break; /* lazy import */ 1382 } 1383 } 1384 if (UnauthorizedAccessOption(module, module_tag, options & PRI_EXPORTEDONLY)) 1385 { 1386 Set_Bip_Error(options & PRI_EXPORTEDONLY? NOENTRY: LOCKED); 1387 pd = 0; 1388 } 1389 else if (options & PRI_DONTIMPORT) 1390 { 1391 dident dummy; 1392 Set_Bip_Error(_hiding_import(functor, module, &dummy) ? IMPORT_PENDING : NOENTRY); 1393 pd = 0; 1394 } 1395 else 1396 { 1397 /* pd == NULL or DEFAULT */ 1398 res = _resolve_import(functor, module, &pd); 1399 switch(res) 1400 { 1401 case PSUCCEED: 1402 break; 1403 1404 case IMPORT_CLASH: 1405 if (_report_error(IMPORT_CLASH_RESOLVE, functor, module, module_tag) == PSUCCEED) 1406 { 1407 /* handler succeeded, try again */ 1408 return visible_procedure(functor, module, module_tag, options); 1409 } 1410 if (!(options & PRI_DONTWARN)) 1411 { 1412 (void) _report_error(IMPORT_CLASH, functor, module, module_tag); 1413 } 1414 res = NOENTRY; 1415 /* fall through */ 1416 1417 case NOENTRY: 1418 if (options & PRI_CREATE) 1419 { 1420 if (!pd) 1421 { 1422 a_mutex_lock(&ModuleLock); 1423 pd = _new_visible_pri(functor, module, 0, DEFAULT); 1424 a_mutex_unlock(&ModuleLock); 1425 _pri_init_vmcode(pd, 0); 1426 } 1427 break; 1428 } 1429 /* fall through */ 1430 1431 default: 1432 Set_Bip_Error(res); 1433 pd = 0; 1434 break; 1435 } 1436 if (pd && options & PRI_REFER) 1437 { 1438 Pri_Set_Reference(pd); 1439 } 1440 } 1441 a_mutex_unlock(&ProcListLock); 1442 return pd; 1443} 1444 1445 1446/*---------------------------------------------------------------------- 1447 * Find or create the qualified descriptor (a reference from ref_module 1448 * to the definition in lookup_module) 1449 * This is used for making qualified calls. 1450 *----------------------------------------------------------------------*/ 1451 1452pri * 1453qualified_procedure(dident functor, dident lookup_module, dident ref_module, type ref_mod_tag) 1454/* Locks: acquires ProcListLock, ModuleLock. */ 1455{ 1456 pri *pd, *visible_pd, *home_pd; 1457 pri **qualified_chain; 1458 module_item *module_property; 1459 dident home_module; 1460 1461 /* If modules are the same, it's the same as visible_procedure() */ 1462 if (lookup_module == ref_module) 1463 return visible_procedure(functor, ref_module, ref_mod_tag, 1464 PRI_CREATE|PRI_REFER); 1465 1466 /* 1467 * All the qualified descriptors are at the end of the list. 1468 * First skip the visibility descriptors, remembering a visible one 1469 * (if any) and the start of qualified descriptor chain (for appending 1470 * later on) 1471 */ 1472 a_mutex_lock(&ProcListLock); 1473 qualified_chain = &DidPtr(functor)->procedure; 1474 pd = DidPtr(functor)->procedure; 1475 visible_pd = 0; 1476 while(IsVisibilityPri(pd)) 1477 { 1478 if (pd->module_def == lookup_module) 1479 visible_pd = pd; 1480 qualified_chain = &pd->nextproc; 1481 pd = pd->nextproc; 1482 } 1483 1484 switch (visible_pd ? PriScope(visible_pd) : DEFAULT) 1485 { 1486 case DEFAULT: 1487 case IMPORT: 1488 case LOCAL: 1489 home_pd = 0; 1490 home_module = lookup_module; 1491 break; 1492 1493 case EXPORT: 1494 home_pd = visible_pd; 1495 home_module = lookup_module; 1496 break; 1497 1498 case IMPEXP: 1499 home_pd = _find_export(visible_pd->did, visible_pd->module_ref, &home_module); 1500 break; 1501 } 1502 1503 /* 1504 * If there is already an appropriate qualified descriptor, use it. 1505 */ 1506 while (pd) /* loop through QUALI descriptors */ 1507 { 1508 if (pd->module_def == ref_module && pd->module_ref == home_module) 1509 { 1510 a_mutex_unlock(&ProcListLock); 1511 return pd; 1512 } 1513 pd = pd->nextproc; 1514 } 1515 1516 /* 1517 * Create a new qualified descriptor and link it to the definition 1518 */ 1519 1520 pd = _new_pri(functor, ref_module); 1521 Pri_Set_Reference(pd); 1522 Pri_Set_Scope(pd, QUALI); 1523 pd->module_ref = home_module; 1524 if (home_pd) 1525 { 1526 _update_def_use(home_pd, pd); 1527 } 1528 else /* undefined procedure for now*/ 1529 { 1530 pd->flags = (pd->flags & ~CODETYPE)|VMCODE; 1531 _pri_init_vmcode(pd, 0); 1532 } 1533 1534 /* insert it at the beginning of the qualified part of the list */ 1535 pd->nextproc = *qualified_chain; 1536 *qualified_chain = pd; 1537 a_mutex_unlock(&ProcListLock); 1538 1539 /* insert it at the beginning of the module list */ 1540 a_mutex_lock(&ModuleLock); 1541 module_property = ModuleItem(ref_module); 1542 pd->next_in_mod = module_property->procedures; 1543 module_property->procedures = pd; 1544 a_mutex_unlock(&ModuleLock); 1545 1546 return(pd); 1547} 1548 1549 1550/*---------------------------------------------------------------------- 1551 * (*pi) is null or a DEFAULT (referenced) descriptor in module 1552 * It is updated to an IMPORT if possible. 1553 * Should be called with ProcListLock 1554 * 1555 * Return codes: 1556 * PSUCCEED import was done (*pi updated) 1557 * NOENTRY there was nothing to import 1558 * IMPORT_CLASH don't know which to import 1559 * CONSISTENCY import would be inconsistent 1560 *----------------------------------------------------------------------*/ 1561 1562static int 1563_resolve_import(dident functor, dident module, pri **pi) 1564{ 1565 pri *pe, *pd; 1566 module_item *module_property; 1567 didlist *imported_mod; 1568 dident exporting_module; 1569 1570 /* for all the modules imported in module, check whether 1571 functor is exported */ 1572 a_mutex_lock(&ModuleLock); 1573 module_property = ModuleItem(module); 1574 imported_mod = module_property->imports; 1575 pe = 0; 1576 while(imported_mod) 1577 { 1578 pd = _find_export(functor, imported_mod->name, &exporting_module); 1579 /* pd is an EXPORT, no IMPEXP */ 1580 if (pd) 1581 { 1582 /* Check whether we found two different ones to import. Note that 1583 * it is possible to find the same one twice because of reexports. 1584 */ 1585 if (pe && pd->module_ref != pe->module_ref) /* Ambiguity? */ 1586 { 1587 a_mutex_unlock(&ModuleLock); 1588 return IMPORT_CLASH; 1589 } 1590 pe = pd; 1591 } 1592 imported_mod = imported_mod->next; 1593 } 1594 if (!pe) 1595 { 1596 a_mutex_unlock(&ModuleLock); 1597 return NOENTRY; 1598 } 1599 1600 if (*pi) /* DEFAULT descriptor already exists, check compatibility */ 1601 { 1602 a_mutex_unlock(&ModuleLock); 1603 if (!_compatible_def_use(pe, *pi)) 1604 { 1605 return INCONSISTENCY; 1606 } 1607 Pri_Set_Scope(*pi, IMPORT); 1608 } 1609 else /* no descriptor yet, create one */ 1610 { 1611 (*pi) = _new_visible_pri(functor, module, module_property, IMPORT); 1612 a_mutex_unlock(&ModuleLock); 1613 } 1614 1615 /* copy the definition */ 1616 _update_def_use(pe, *pi); 1617 1618 return PSUCCEED; 1619} 1620 1621 1622/* 1623 * Check whether functor potentially imports into module and return 1624 * SYSTEM if yes and it's a SYSTEM procedure 1625 * IMPORT if yes 1626 * 0 otherwise 1627 */ 1628static uint32 1629_hiding_import(dident functor, dident module, dident *exporting_module) 1630{ 1631 pri *pd; 1632 module_item *module_property; 1633 didlist *imported_mod; 1634 dident found_module; 1635 int found = 0; 1636 1637 a_mutex_lock(&ModuleLock); 1638 module_property = ModuleItem(module); 1639 imported_mod = module_property->imports; 1640 while(imported_mod) 1641 { 1642 pd = _find_export(functor, imported_mod->name, &found_module); 1643 if (pd) 1644 { 1645 *exporting_module = found_module; 1646 if (pd->flags & SYSTEM) 1647 { 1648 a_mutex_unlock(&ModuleLock); 1649 return SYSTEM; 1650 } 1651 found = 1; 1652 } 1653 imported_mod = imported_mod->next; 1654 } 1655 a_mutex_unlock(&ModuleLock); 1656 return found? IMPORT: 0; 1657} 1658 1659 1660void 1661resolve_pending_imports(pri *procs_in_module) 1662{ 1663 pri *pd; 1664 for(pd = procs_in_module; pd; pd = pd->next_in_mod) 1665 { 1666 if (PriScope(pd) == DEFAULT) 1667 (void) _resolve_import(pd->did, pd->module_def, &pd); 1668 } 1669} 1670 1671 1672/*---------------------------------------------------------------------- 1673 * Abolish (remove) a procedure 1674 * 1675 * We allow 1676 * null -> null 1677 * DEFAULT -> DEFAULT 1678 * LOCAL -> DEFAULT 1679 * EXPORT -> DEFAULT 1680 * IMPORT -> DEFAULT 1681 * 1682 * The descriptor is made a DEFAULT-descriptor and reinitialised 1683 * as much as possible. When it was referenced, some properties 1684 * must be kept otherwise existing calls could become inconsistent. 1685 *----------------------------------------------------------------------*/ 1686 1687int 1688pri_abolish(pri *pd) /* a visibility descriptor */ 1689{ 1690 switch(PriScope(pd)) 1691 { 1692 case IMPORT: 1693 case IMPEXP: 1694 case QUALI: 1695 return ACCESSING_NON_LOCAL; 1696 default: 1697 pri_init_code(pd, PriCodeType(pd)); 1698 pd->flags = (pd->flags & DESCRIPTOR_FLAGS) 1699 | (pd->flags & PF_DONT_CHANGE_WHEN_DEFINED); 1700 break; 1701 } 1702 return PSUCCEED; 1703} 1704 1705 1706/* 1707 * In preparation to erasing the whole module, erase and free all the 1708 * procedure descriptors in this module. 1709 */ 1710void 1711erase_module_procs(pri *procs_in_module) 1712/* Locks: acquires ProcListLock. */ 1713{ 1714 pri *pd, **pf; 1715 1716 a_mutex_lock(&ProcListLock); 1717 while(procs_in_module) 1718 { 1719 pd = procs_in_module; 1720 procs_in_module = pd->next_in_mod; 1721 (void) pri_abolish(pd); /* abolish the procedure */ 1722 _pri_clear_code(pd); /* free code field */ 1723 pf = &(DidPtr(pd->did)->procedure); /* unlink from did-chain */ 1724 while (*pf != pd) 1725 pf = &((*pf)->nextproc); 1726 *pf = pd->nextproc; 1727 _free_pri(pd); /* free descriptor */ 1728 } 1729 a_mutex_unlock(&ProcListLock); 1730} 1731 1732 1733/* 1734 * Reclaim all the blocks that belong to one procedure. All the blocks 1735 * are linked together with the ProcLink item which is stored at the 1736 * beginning of each block, right after the memory header. 1737 */ 1738void 1739reclaim_procedure(vmcode *code) 1740{ 1741 vmcode *next; 1742 1743 do 1744 { 1745 next = (vmcode *) *code; 1746 if (BlockType(code) == GROUND_TERM) 1747 { 1748 a_mutex_lock(&ProcChainLock); 1749 add_proc_to_chain((pri *) code, &CompiledStructures); 1750 a_mutex_unlock(&ProcChainLock); 1751 } 1752 else if (BlockType(code) == UNDEFINED_PROC) 1753 hg_free_size((generic_ptr) code, sizeof(vmcode) * (UNDEF_CODE_SIZE + PROC_PREFIX_SIZE)); 1754 else 1755 hg_free((generic_ptr) code); 1756 } 1757 while (code = next); 1758} 1759 1760 1761/* 1762 * Reclaim the space occupied by all previously abolished or otherwise replaced 1763 * procedures. This should be done by a garbage collector only, because 1764 * some living pointers can still exist to the dead code. To make it 1765 * simple, we call this function only in the topmost top-level so that 1766 * there is a reasonable probability that the code is really dead. 1767 */ 1768void 1769reclaim_abolished_procedures(void) 1770{ 1771 proc_duet *p_duet; 1772 vmcode *code; 1773 1774 a_mutex_lock(&ProcChainLock); 1775 for(;;) 1776 { 1777 p_duet = AbolishedProcedures; 1778 if (!p_duet) 1779 break; 1780 code = (vmcode *) (p_duet->desc); 1781 reclaim_procedure(ProcHeader(code)); 1782 delete_proc_from_chain((pri *) code, &AbolishedProcedures); 1783 } 1784 for(;;) 1785 { 1786 p_duet = CompiledStructures; 1787 if (!p_duet) 1788 break; 1789 code = (vmcode *) (p_duet->desc); 1790 reclaim_ground_structure(code); 1791 delete_proc_from_chain((pri *) code, &CompiledStructures); 1792 } 1793 a_mutex_unlock(&ProcChainLock); 1794 return; 1795} 1796 1797 1798/* 1799 * Insert the procedure code into the abolished code list. 1800 */ 1801void 1802remove_procedure(pri *proc) 1803{ 1804 vmcode *code = PriCode(proc); 1805 1806 if (!code) 1807 return; 1808 1809 if (PriCodeType(proc) == VMCODE) 1810 { 1811 if (IsUndefined(code)) 1812 { 1813 reclaim_procedure(ProcHeader(code)); 1814 } 1815 else if (PriFlags(proc) & PROC_DYNAMIC) 1816 { 1817#ifdef OLD_DYNAMIC 1818 a_mutex_lock(&ProcChainLock); 1819 add_proc_to_chain((pri *) code, &AbolishedDynProcedures); 1820 /* Mark the abolish clock into the death of the first clause */ 1821 Death(StartOfAss(code)) = DynGlobalClock; 1822 delete_proc_from_chain(proc, &DynamicProcedures); 1823 a_mutex_unlock(&ProcChainLock); 1824#else 1825 ec_free_dyn_code(code); 1826#endif 1827 PriFlags(proc) &= ~PROC_DYNAMIC; 1828 } 1829 else 1830 { 1831 a_mutex_lock(&ProcChainLock); 1832 add_proc_to_chain((pri *) code, &AbolishedProcedures); 1833 a_mutex_unlock(&ProcChainLock); 1834 } 1835 } 1836 PriCode(proc) = (vmcode *) 0; /* just to catch bugs */ 1837} 1838 1839 1840#ifdef PRINTAM 1841/* 1842 * Debugging support: Find out (the brute-force way) 1843 * which procedure a code address belongs to 1844 */ 1845pri *ec_code_procedure(vmcode *code) 1846{ 1847 int idx = 0; 1848 dident functor; 1849 1850 while (next_functor(&idx, &functor)) 1851 { 1852 pri *pd; 1853 for(pd=DidPtr(functor)->procedure; IsVisibilityPri(pd); pd=pd->nextproc) 1854 { 1855 if (pd->module_def == pd->module_ref 1856 && PriCodeType(pd) == VMCODE 1857 && PriCode(pd) <= code 1858 && code < PriCode(pd) + ProcCodeSize(PriCode(pd))) 1859 { 1860 return pd; 1861 } 1862 } 1863 } 1864 return 0; 1865} 1866#endif 1867 1868 1869/*---------------------------------------------------------------------- 1870 * Functions to enter kernel built-ins 1871 *----------------------------------------------------------------------*/ 1872 1873static pri * 1874_define_built_in(dident did1, int (*function) (/* ??? */), word flags, dident mod, uint32 vis, int nondet) 1875{ 1876 pri *pd; 1877 pri_code_t pricode; 1878 type tm; 1879 1880 tm.kernel = ModuleTag(d_.kernel_sepia); 1881 switch(vis) 1882 { 1883 case LOCAL: pd = local_procedure(did1, mod, tm, PRI_CREATE); break; 1884 case EXPORT: pd = export_procedure(did1, mod, tm); break; 1885 default: return 0; 1886 } 1887 1888 pd->flags |= (flags & (UNIFTYPE|PROC_DEMON))|SYSTEM|DEBUG_DB|DEBUG_DF; 1889 if ((flags & UNIFTYPE) == U_SIMPLE) 1890 /* by default all simples bind the last argument */ 1891 pd->mode = BoundArg(DidArity(PriDid(pd)), CONSTANT); 1892 1893 if ((flags & CODETYPE) == VMCODE) 1894 { 1895 (void) b_built_code(pd, (word) function, nondet); 1896 } 1897 else 1898 { 1899 (void) ec_panic("Illegal codetype", "_define_built_in()"); \ 1900 } 1901 return pd; 1902} 1903 1904/* 1905 * A global built_in in sepia_kernel. 1906 */ 1907pri * 1908built_in(dident did1, int (*func) (/* ??? */), word flags) 1909{ 1910 return _define_built_in(did1, func, flags, d_.kernel_sepia, EXPORT, 0); 1911} 1912 1913/* 1914 * A local built_in in sepia_kernel. 1915 */ 1916pri * 1917local_built_in(dident did1, int (*func) (/* ??? */), word flags) 1918{ 1919 return _define_built_in(did1, func, flags, d_.kernel_sepia, LOCAL, 0); 1920} 1921 1922/* 1923 * An exported built_in in sepia_kernel. 1924 */ 1925pri * 1926exported_built_in(dident did1, int (*func) (/* ??? */), word flags) 1927{ 1928 return _define_built_in(did1, func, flags, d_.kernel_sepia, EXPORT, 0); 1929} 1930 1931/* 1932 * A local external in module 1933 * Function for C interface 1934 */ 1935int 1936ec_external(dident did1, int (*func) (/* ??? */), dident module) 1937{ 1938 return _define_built_in(did1, func, B_UNSAFE, module, LOCAL, 0)? PSUCCEED: PFAIL; 1939} 1940 1941/* 1942 * Backtracking builtin definition. 1943 */ 1944pri * 1945b_built_in(dident did1, int (*func) (/* ??? */), dident module) 1946{ 1947 return _define_built_in(did1, func, B_UNSAFE, module, LOCAL, 1); 1948} 1949