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 * VERSION $Id: bip_delay.c,v 1.10 2015/05/20 23:52:26 jschimpf Exp $ 25 */ 26 27/**************************************************************************** 28 * 29 * SEPIA Built-in Predicates for Coroutining. 30 * 31 * 32 *****************************************************************************/ 33 34#define BAD_RESTORE_WL -274 35/* 36 * INCLUDES: 37 */ 38#include "config.h" 39#include "sepia.h" 40#include "types.h" 41#include "embed.h" 42#include "mem.h" 43#include "debug.h" 44#include "error.h" 45#include "dict.h" 46#include "emu_export.h" 47#include "property.h" 48 49/* 50 * EXTERNAL VARIABLE DEFINITIONS: 51 */ 52pword *p_meta_arity_; 53 54/* 55 * STATIC VARIABLE DEFINITIONS: 56 */ 57static int p_delayed_goals(value vres, type tres), 58 p_last_suspension(value v, type t), 59 p_new_delays(value v1, type t1, value vres, type tres), 60 p_nonground3(value vn, type tn, value vterm, type tterm, value vlist, type tlst), 61 p_meta_bind(value vmeta, type tmeta, value vterm, type tterm), 62 p_nonground2(value val, type tag, value vvar, type tvar), 63 p_term_variables_lr(value vterm, type tterm, value vlist, type tlst), 64 p_term_variables_rl(value vterm, type tterm, value vlist, type tlst), 65 p_term_variables_array(value vterm, type tterm, value varr, type tarr), 66 p_replace_attribute(value vmeta, type tmeta, value vterm, type tterm, value vm, type tm), 67 p_kill_suspension(value vsusp, type tsusp, value vt, type tt), 68 p_unschedule_suspension(value vsusp, type tsusp), 69 p_setuniv(value v, type t), 70 p_suspensions(value vres, type tres), 71 p_new_suspensions(value vlast, type tlast, value vres, type tres), 72 p_suspension_to_goal(value vsusp, type tsusp, value vgoal, type tgoal, value vmod, type tmod), 73 p_suspensions_to_goals(value vSusps, type tSusps, value vGoals, type tGoals, value vLink, type tLink), 74 p_current_suspension(value vres, type tres, value vlast, type tlast), 75 p_insert_suspension(value vvars, type tvars, value vsusp, type tsusp, value vn, type tn, value vsl, type tsl), 76 p_enter_suspension_list(value vn, type tn, value vatt, type tatt, value vsusp, type tsusp), 77 p_add_attribute(value vv, type tv, value va, type ta, value vm, type tm), 78 p_get_attribute(value vv, type tv, value va, type ta, value vm, type tm), 79 p_get_attributes(value vv, type tv, value va, type ta, value vm, type tm, value vmod, type tmod), 80 p_get_postponed(value v, type t), 81 p_get_postponed_nonempty(value v, type t), 82 p_postpone_suspensions(value vpos, type tpos, value vattr, type tattr), 83 p_reinit_postponed(value vold, type told), 84 p_reset_postponed(value vold, type told), 85 p_subcall_init(), 86 p_subcall_fini(value vs, type ts), 87 p_set_priority(value vp, type tp), 88 p_set_priority2(value vp, type tp, value vt, type tt), 89 p_get_priority(value vp, type tp), 90 p_first_woken(value pv, type pt, value v, type t), 91 p_last_scheduled(value vg, type tg), 92 p_new_scheduled(value vold, type told, value vl, type tl), 93 p_notify_constrained(value v, type t), 94 p_init_suspension_list(value vpos, type tpos, value vattr, type tattr), 95 p_undo_meta_bind(value vp, type tp, value vv, type tv), 96 p_do_meta_bind(value vp, type tp, value vt, type tt), 97 p_meta_index(value vname, type tname, value vi, type ti), 98 p_set_suspension_arg(value vs, type ts, value vi, type tn, value v, type t), 99 p_get_suspension_data(value vs, type ts, value vwhat, type twhat, value v, type t), 100 p_set_suspension_data(value vs, type ts, value vwhat, type twhat, value v, type t), 101 p_get_suspension_number(value vs, type ts, value vn, type tn), 102 p_set_suspension_number(value vs, type ts, value vn, type tn); 103 104int p_merge_suspension_lists(value vpos1, type tpos1, value vattr1, type tattr1, value vpos2, type tpos2, value vattr2, type tattr2), 105 p_schedule_woken(value vl, type tl), 106 p_schedule_suspensions(value vpos, type tpos, value vattr, type tattr), 107 p_set_suspension_priority(value vsusp, type tsusp, value vprio, type tprio); 108 109static pword *_make_goal_list(pword *last, register int undelay); 110static int modify_attribute(value vv, type tv, value va, type ta, value vm, type tm, int replace); 111 112 113static type tref; 114static dident d_qualified_goal_, 115 d_es_2_, 116 d_postponed_; 117 118/* 119 * LOCAL MACROS 120 */ 121 122#define Get_Suspension(vsusp, tsusp, susp) \ 123 if (IsRef(tsusp)) \ 124 { Bip_Error(INSTANTIATION_FAULT); } \ 125 if (!IsSusp(tsusp)) \ 126 { Bip_Error(TYPE_ERROR); } \ 127 (susp) = (vsusp).ptr; 128 129 130/* 131 * FUNCTION DEFINITIONS: 132 */ 133void 134bip_delay_init(int flags) 135{ 136 value v; 137 138 tref.kernel = TREF; 139 d_qualified_goal_ = in_dict("qualified_goal", 0); 140 d_es_2_ = in_dict("es", 2); 141 d_postponed_ = in_dict("postponed", 0); 142 if (flags & INIT_SHARED) 143 { 144 built_in(in_dict("delayed_goals",1), p_delayed_goals, 145 B_UNSAFE|U_GLOBAL) -> mode = BoundArg(1, NONVAR); 146 built_in(in_dict("nonground", 3), p_nonground3, B_UNSAFE|U_GLOBAL) 147 -> mode = BoundArg(2, NONVAR) | BoundArg(3, NONVAR); 148 built_in(in_dict("term_variables", 2), p_term_variables_rl, 149 B_UNSAFE|U_GLOBAL) -> mode = BoundArg(2, NONVAR); 150 built_in(in_dict("term_variables_rl", 2), p_term_variables_rl, 151 B_UNSAFE|U_GLOBAL) -> mode = BoundArg(2, NONVAR); 152 built_in(in_dict("term_variables_lr", 2), p_term_variables_lr, 153 B_UNSAFE|U_GLOBAL) -> mode = BoundArg(2, NONVAR); 154 built_in(in_dict("term_variables_array", 2), p_term_variables_array, 155 B_UNSAFE|U_GLOBAL) -> mode = BoundArg(2, NONVAR); 156 local_built_in(in_dict("meta_bind", 2), p_meta_bind, B_UNSAFE|U_UNIFY) 157 -> mode = BoundArg(1, NONVAR) | BoundArg(2, NONVAR); 158 local_built_in(in_dict("undo_meta_bind", 2), p_undo_meta_bind, B_UNSAFE|U_GLOBAL) -> mode = BoundArg(2, NONVAR); 159 (void) local_built_in(in_dict("do_meta_bind", 2), p_do_meta_bind, B_UNSAFE); 160 exported_built_in(in_dict("meta_index", 2), p_meta_index, B_UNSAFE|U_SIMPLE) 161 -> mode = BoundArg(1, CONSTANT) | BoundArg(2, CONSTANT); 162 (void) built_in(in_dict("insert_suspension", 4), p_insert_suspension, 163 B_UNSAFE); 164 (void) built_in(in_dict("enter_suspension_list", 3), p_enter_suspension_list, 165 B_UNSAFE); 166 built_in(in_dict("set_suspension_arg", 3), 167 p_set_suspension_arg, B_SAFE); 168 built_in(in_dict("set_suspension_data", 3), 169 p_set_suspension_data, B_SAFE); 170 built_in(in_dict("get_suspension_data", 3), 171 p_get_suspension_data, B_UNSAFE|U_UNIFY) 172 -> mode = BoundArg(2, NONVAR); 173 (void) exported_built_in(in_dict("set_suspension_number", 2), 174 p_set_suspension_number, B_SAFE); 175 exported_built_in(in_dict("get_suspension_number", 2), 176 p_get_suspension_number, B_UNSAFE|U_SIMPLE) 177 -> mode = BoundArg(2, CONSTANT); 178 exported_built_in(in_dict("suspensions_to_goals", 3), 179 p_suspensions_to_goals, B_UNSAFE|U_UNIFY) 180 -> mode = BoundArg(2, NONVAR); 181 built_in(in_dict("suspension_to_goal", 3), p_suspension_to_goal, 182 B_UNSAFE|U_UNIFY) 183 -> mode = BoundArg(2, NONVAR) | BoundArg(3, CONSTANT); 184 (void) exported_built_in(in_dict("kill_suspension", 2), 185 p_kill_suspension, B_UNSAFE); 186 (void) exported_built_in(in_dict("unschedule_suspension", 1), 187 p_unschedule_suspension, B_SAFE); 188 (void) exported_built_in(in_dict("replace_attribute", 3), 189 p_replace_attribute, B_UNSAFE); 190 (void) exported_built_in(in_dict("last_suspension", 1), 191 p_last_suspension, B_UNSAFE|U_SIMPLE); 192 (void) built_in(in_dict("notify_constrained", 1), 193 p_notify_constrained, B_UNSAFE); 194 b_built_in(in_dict("current_suspension",2), p_current_suspension, 195 d_.kernel_sepia) -> mode = BoundArg(1, NONVAR); 196 built_in(in_dict("suspensions",1), p_suspensions, 197 B_UNSAFE|U_GLOBAL) -> mode = BoundArg(1, NONVAR); 198 exported_built_in(in_dict("new_suspensions",2), p_new_suspensions, 199 B_UNSAFE|U_GLOBAL) -> mode = BoundArg(2, NONVAR); 200 exported_built_in(in_dict("new_delays",2),p_new_delays, 201 B_UNSAFE|U_GLOBAL) -> mode = BoundArg(2, NONVAR); 202 exported_built_in(in_dict("first_woken", 2), p_first_woken, 203 B_UNSAFE|U_GLOBAL) -> mode = BoundArg(2, NONVAR); 204 (void) built_in(in_dict("nonground", 2), p_nonground2, 205 B_UNSAFE|U_UNIFY); 206 (void) built_in(in_dict("schedule_woken", 1), p_schedule_woken, 207 B_SAFE); 208 (void) built_in(in_dict("init_suspension_list", 2), 209 p_init_suspension_list, B_SAFE|U_SIMPLE); 210 (void) built_in(in_dict("merge_suspension_lists", 4), 211 p_merge_suspension_lists, B_SAFE); 212 (void) built_in(in_dict("schedule_suspensions", 2), 213 p_schedule_suspensions, B_SAFE); 214 (void) built_in(in_dict("postpone_suspensions", 2), 215 p_postpone_suspensions, B_SAFE); 216 (void) built_in(in_dict("set_suspension_priority", 2), 217 p_set_suspension_priority, B_SAFE); 218 (void) local_built_in(in_dict("get_postponed", 1), 219 p_get_postponed, B_UNSAFE|U_GLOBAL); 220 (void) local_built_in(in_dict("get_postponed_nonempty", 1), 221 p_get_postponed_nonempty, B_UNSAFE|U_GLOBAL); 222 (void) local_built_in(in_dict("reinit_postponed", 1), 223 p_reinit_postponed, B_UNSAFE|U_GLOBAL); 224 (void) local_built_in(in_dict("reset_postponed", 1), 225 p_reset_postponed, B_UNSAFE|U_GLOBAL); 226 227 /* these two are used in Grace */ 228 exported_built_in(in_dict("last_scheduled", 1), p_last_scheduled, B_UNSAFE|U_GLOBAL) -> mode = BoundArg(1, NONVAR); 229 exported_built_in(in_dict("new_scheduled", 2), p_new_scheduled, B_UNSAFE|U_GLOBAL) -> mode = BoundArg(2, NONVAR); 230 231 (void) built_in(in_dict("get_priority", 1), p_get_priority, B_UNSAFE); 232 (void) exported_built_in(in_dict("set_priority", 1), p_set_priority, B_UNSAFE); 233 (void) exported_built_in(in_dict("set_priority", 2), p_set_priority2, B_UNSAFE); 234 (void) exported_built_in(in_dict("subcall_init", 0), p_subcall_init, B_SAFE); 235 (void) exported_built_in(in_dict("subcall_fini", 1), p_subcall_fini, B_UNSAFE); 236 (void) exported_built_in(in_dict("add_attribute", 3), p_add_attribute, 237 B_UNSAFE); 238 exported_built_in(in_dict("get_attribute", 3), p_get_attribute, 239 B_UNSAFE|U_GLOBAL) -> mode = BoundArg(2, NONVAR); 240 exported_built_in(in_dict("get_attributes", 4), p_get_attributes, 241 B_UNSAFE|U_GLOBAL) -> 242 mode = BoundArg(2, NONVAR) | BoundArg(4, CONSTANT); 243 (void) exported_built_in(in_dict("setuniv", 1), p_setuniv, B_UNSAFE); 244 } 245 246 /* Global variable meta_arity holds the current number of attribute slots */ 247 v.nint = 1; 248 p_meta_arity_ = init_kernel_var(flags, in_dict("meta_arity", 0), v, tint); 249} 250 251 252/* p_delayed_goals: delayed_goals/1 253 * one argument gets bound to the list 254 * of delayed goals. 255 */ 256 257static int 258p_delayed_goals(value vres, type tres) 259{ 260 pword result; 261 262 /* if invoked with [], do a more efficient check only */ 263 if (IsNil(tres)) { 264 pword *env = LD; 265 while (env > LD_END) { 266 if(!SuspDead(env)) { 267 Fail_ 268 } 269 env = SuspPrevious(env); 270 } 271 Succeed_; 272 } 273 if (result.val.ptr = _make_goal_list(LD_END, 0)) 274 result.tag.kernel = TLIST; 275 else 276 result.tag.kernel = TNIL; 277 Return_Unify_Pw(result.val, result.tag, vres, tres); 278} 279 280/* 281 * last_suspension(-LD) - auxiliary predicate 282 * returns the current top of delayed goals list 283 */ 284 285static int 286p_last_suspension(value v, type t) 287{ 288 pword result; 289 Check_Ref(t) 290 Make_Susp(&result, LD); 291 Return_Unify_Pw(v,t,result.val,result.tag); 292} 293 294 295/* 296 * Save and re-init WP, LD_END and the woken lists. 297 */ 298 299static int 300p_subcall_init() 301{ 302 if (WL < GB) { 303 Trail_Pword(&TAGGED_WL) 304 } 305 WL = wl_init(); /* saves old WP, WL, LD */ 306 Set_WP(PRIORITY_MAIN) 307 Succeed_; 308} 309 310 311/* 312 * Restore saved WP, LD_END, and woken lists. 313 * Kill and collect all newly delayed goals. 314 */ 315 316static int 317p_subcall_fini(value vres, type tres) 318{ 319 pword result; 320 321 if (IsNil(tres)) 322 { 323 /* just check for delayed goals, fail if a live one found */ 324 pword *env = LD; 325 while (env > LD_END) 326 { 327 if(!SuspDead(env)) 328 { 329 Fail_; 330 } 331 env = SuspPrevious(env); 332 } 333 result.tag.kernel = TNIL; 334 } 335 else if (IsRef(tres) || IsList(tres)) 336 { 337 /* collect, kill, and return the delayed goals */ 338 if (result.val.ptr = _make_goal_list(LD_END, 1)) 339 result.tag.kernel = TLIST; 340 else 341 result.tag.kernel = TNIL; 342 } 343 else 344 { 345 Bip_Error(TYPE_ERROR); 346 } 347 348 /* reset WL and WP, leave LD to the garbage collector */ 349 Set_WP(WLPreviousWP(WL)->val.nint); 350 if (WL < GB) { 351 Trail_Pword(&TAGGED_WL) 352 } 353 WL = WLPrevious(WL)->val.ptr; 354 355 Return_Unify_Pw(result.val, result.tag, vres, tres); 356} 357 358 359/* 360 * new_delays(+Old_LD, -List) 361 * return list of delayed goals created since Old_LD was saved 362 * the goals are marked as woken! 363 * We assume that Old_LD >= LD_END 364 */ 365 366/*ARGSUSED*/ 367static int 368p_new_delays(value v1, type t1, value vres, type tres) 369{ 370 pword result, *susp; 371 Get_Suspension(v1, t1, susp) 372 if (IsNil(tres)) /* just check for delayed goals */ 373 { 374 register pword *env = LD; 375 while (env > susp) 376 { 377 if(!SuspDead(env)) 378 { 379 Fail_; 380 } 381 env = SuspPrevious(env); 382 } 383 Succeed_; 384 } 385 else if (IsRef(tres) || IsList(tres)) 386 { 387 if (result.val.ptr = _make_goal_list(susp, 1)) 388 result.tag.kernel = TLIST; 389 else 390 result.tag.kernel = TNIL; 391 Return_Unify_Pw(result.val, result.tag, vres, tres); 392 } 393 else 394 { 395 Bip_Error(TYPE_ERROR); 396 } 397} 398 399 400static pword * 401_make_goal_list(pword *last, register int undelay) 402{ 403 pword *env = LD; 404 register pword *pw, *head = (pword *) 0; 405 406 while (env > last) 407 { 408 if(!SuspDead(env)) 409 { 410 if (undelay) 411 { 412 Set_Susp_Dead(env); 413 } 414 pw = Gbl_Tg; 415 Gbl_Tg += 2; /* allocate list */ 416 Check_Gc 417 *pw = env[SUSP_GOAL]; 418 if (head) 419 { 420 (pw+1)->val.ptr = head; /* prepend to list */ 421 (pw+1)->tag.kernel = TLIST; 422 } 423 else /* first one */ 424 (pw+1)->tag.kernel = TNIL; 425 head = pw; /* update the list head */ 426 } 427 env = SuspPrevious(env); 428 } 429 return head; 430} 431 432 433/* 434 * suspensions(?List) 435 * suspensions(+Old, ?List) 436 * 437 * return the global list of suspensions (possibly starting from Old) 438 * leaving out the woken ones. 439 */ 440 441static int 442_suspensions(value vres, type tres, pword *last) 443{ 444 pword result; 445 pword *env = LD; 446 447 if (IsNil(tres)) 448 { 449 while (env > last) 450 { 451 if (!SuspDead(env)) 452 { 453 Fail_ 454 } 455 env = SuspPrevious(env); 456 } 457 Succeed_; 458 } 459 else if (!(IsRef(tres) || IsList(tres))) 460 { 461 Bip_Error(TYPE_ERROR); 462 } 463 464 result.tag.kernel = TNIL; 465 while (env > last) 466 { 467 if (!SuspDead(env)) 468 { 469 register pword *pw = TG; 470 Push_List_Frame(); 471 Make_Susp(&pw[0], env); 472 pw[1] = result; 473 Make_List(&result, pw); 474 } 475 env = SuspPrevious(env); 476 } 477 Return_Unify_Pw(result.val, result.tag, vres, tres); 478} 479 480static int 481p_suspensions(value vres, type tres) 482{ 483 return _suspensions(vres, tres, LD_END); 484} 485 486/* 487 * Backtracking external 488 * current_suspension(-S, State) 489 */ 490static int 491p_current_suspension(value vres, type tres, value vlast, type tlast) 492{ 493 pword *de = IsTag(tlast.kernel, TSUSP) ? SuspPrevious(vlast.ptr) : LD; 494 while (de > LD_END) 495 { 496 if (!SuspDead(de)) 497 { 498 pword result; 499 Make_Susp(&result, de); 500 Remember(2, result.val, result.tag); 501 Return_Unify_Pw(vres, tres, result.val, result.tag); 502 } 503 de = SuspPrevious(de); 504 } 505 Cut_External; 506 Fail_; 507} 508 509static int 510p_new_suspensions(value vlast, type tlast, value vres, type tres) 511{ 512 pword *susp; 513 Get_Suspension(vlast, tlast, susp) 514 return _suspensions(vres, tres, susp); 515} 516 517 518/* 519 * Bind a metaterm without raising an event 520 */ 521static int 522p_meta_bind(value vmeta, type tmeta, value vterm, type tterm) 523{ 524 if (IsMeta(tmeta)) { 525 return meta_bind(vmeta.ptr, vterm, tterm); 526 } 527 else if (IsRef(tmeta)) { 528 Bip_Error(INSTANTIATION_FAULT); 529 } 530 else { 531 Bip_Error(TYPE_ERROR); 532 } 533} 534 535 536 537/* 538 * Count the structures on the global stack 539 */ 540int 541global_stat(void) 542{ 543 pword *tg = TG_ORIG; 544 word arity; 545 word gsize = 2 * (Gbl_Tg - tg); 546 word size_de = 0; /* delayed goals */ 547 word size_mt = 0; /* metaterms */ 548 word size_hb = 0; /* heap buffers and strings */ 549 word size_st = 0; /* structures */ 550 word size_ls = 0; /* lists */ 551 word size_re = 0; /* rest */ 552 553 while (tg < Gbl_Tg) 554 { 555 switch (TagType(tg->tag)) 556 { 557 case TDE: 558 size_de += 2 * SUSP_SIZE; 559 tg += SUSP_SIZE; 560 break; 561 562 case TEXTERN: 563 size_hb += 2 * 2; 564 tg += 2; 565 break; 566 567 case TBUFFER: 568 size_hb += 2 * BufferPwords(tg); 569 tg += BufferPwords(tg); 570 break; 571 572 case TDICT: 573 arity = DidArity(tg->val.did); 574 if (arity) 575 size_st += 2 * (arity + 1); 576 else 577 size_re += 2; 578 tg += arity + 1; 579 break; 580 581 case TMETA: 582 size_mt += 4 + 2 * DidArity(tg[1].val.ptr->val.did); 583 tg += 2; 584 break; 585 586 case TLIST: 587 size_ls += 4; 588 tg++; 589 break; 590 591 default: 592 tg++; 593 size_re += 2; 594 } 595 } 596 p_fprintf(current_err_, "DE = %9d \t%5.1f %%\nMT = %9d \t%5.1f %%\nST = %9d \t%5.1f %%\nLS = %9d \t%5.1f %%\nHB = %9d \t%5.1f %%\nRE = %9d \t%5.1f %%\nTotal = %d\n", 597 size_de, (100.0 * size_de)/gsize, 598 size_mt, (100.0 * size_mt)/gsize, 599 size_st, (100.0 * size_st)/gsize, 600 size_ls, (100.0 * size_ls)/gsize, 601 size_hb, (100.0 * size_hb)/gsize, 602 size_re, (100.0 * size_re)/gsize, 603 gsize); 604 ec_flush(current_err_); 605 Succeed_; 606} 607 608 609static int 610p_suspension_to_goal(value vsusp, type tsusp, value vgoal, type tgoal, value vmod, type tmod) 611{ 612 register pword *susp; 613 Prepare_Requests; 614 615 Check_Output_Structure(tgoal); 616 Check_Output_Atom(tmod); 617 Get_Suspension(vsusp, tsusp, susp) 618 if (SuspDead(susp)) /* fail for dead suspensions */ 619 { Fail_; } 620 621 Request_Unify_Pw(vgoal, tgoal, susp[SUSP_GOAL].val, susp[SUSP_GOAL].tag) 622 Request_Unify_Pw(vmod, tmod, susp[SUSP_MODULE].val, susp[SUSP_MODULE].tag) 623 Return_Unify 624} 625 626 627/* 628 * suspensions_to_goals(+ListOfSusps, -ListOfGoals, -Link) 629 * Convert a list of suspensions to the corresponding difference list of goals 630 */ 631 632static int 633p_suspensions_to_goals(value vSusps, type tSusps, value vGoals, type tGoals, value vLink, type tLink) 634{ 635 pword result, *where = &result; 636 Prepare_Requests; 637 638 result.tag.kernel = TNIL; 639 while(IsList(tSusps)) 640 { 641 pword *susp, *list; 642 /* deref missing */ 643 Get_Suspension((vSusps.ptr)->val, (vSusps.ptr)->tag, susp); 644 if (!SuspDead(susp)) 645 { 646 Make_List(where, TG); 647 where = TG; 648 Push_List_Frame(); 649 *where++ = susp[SUSP_GOAL]; /*** CAR ***/ 650 } 651 list = vSusps.ptr + 1; /*** CDR ***/ 652 Dereference_(list); 653 vSusps = list->val; 654 tSusps = list->tag; 655 } 656 if (IsNil(result.tag)) { /* no suspensions found */ 657 where = TG++; 658 Check_Gc; 659 Make_Ref(&result, where); 660 } 661 Make_Var(where); 662 Request_Unify_Pw(vLink, tLink, where->val, where->tag); 663 Request_Unify_Pw(result.val, result.tag, vGoals, tGoals); 664 Return_Unify; 665} 666 667 668static int 669p_kill_suspension(value vsusp, type tsusp, value vt, type tt) 670{ 671 register pword *susp; 672 673 if (IsRef(tsusp)) /* For convenience when using demons first iteration */ 674 { Succeed_; } 675 if (!IsSusp(tsusp)) 676 { Bip_Error(TYPE_ERROR); } 677 susp = vsusp.ptr; 678 Check_Integer(tt) 679 680 if (!SuspDead(susp)) 681 { 682 /* trail depending on the vt arg; this is necessary to make 683 * some user actions non-backtrackable 684 */ 685 if (vt.nint) { 686 Set_Susp_Dead(susp); 687 } else { 688 Set_Susp_Dead_Untrailed(susp); 689 } 690 } 691 Succeed_; 692} 693 694 695/* 696 * unschedule_suspension(+Susp) 697 * If suspension is already dead or unscheduled: do nothing. 698 * Otherwise, unschedule, but leave physically in woken list. 699 * Non-demons get killed instead. The assumption here is that everything the 700 * woken goal was supposed to do has become redundant in the current situation. 701 */ 702static int 703p_unschedule_suspension(value vsusp, type tsusp) 704{ 705 pword *susp; 706 Get_Suspension(vsusp, tsusp, susp) 707 if (!SuspDead(susp) && SuspScheduled(susp)) 708 { 709 if (SuspDemon(susp)) { 710 Set_Susp_Unscheduled(susp); 711 } else { 712 Set_Susp_Dead(susp); 713 } 714 } 715 Succeed_; 716} 717 718 719/* 720 * insert_suspension(+TermWithVariables, +Suspension, +Position, +Module) 721 * 722 * Module does not need to be a module, just an attribute slot name. 723 */ 724static int 725p_insert_suspension(value vvars, type tvars, value vsusp, type tsusp, value vn, type tn, value vsl, type tsl) 726{ 727 pword *susp; 728 int slot; 729 int res; 730 731 Get_Suspension(vsusp, tsusp, susp) 732 Check_Integer(tn); 733 if (vn.nint < 1) { 734 Bip_Error(RANGE_ERROR) 735 } 736 if (IsInteger(tsl)) { 737 slot = vsl.nint; 738 if (slot <= 0 || slot > p_meta_arity_->val.nint) { 739 Bip_Error(RANGE_ERROR) 740 } 741 } else if (IsAtom(tsl)) { 742 slot = meta_index(vsl.did); 743 if (slot == 0) { 744 Bip_Error(UNDEF_ATTR); 745 } 746 } 747 else { 748 Bip_Error(TYPE_ERROR) 749 } 750 res = deep_suspend(vvars, tvars, (int) vn.nint, susp, slot); 751 if (res < 0) { 752 Bip_Error(res) 753 } 754 Succeed_; 755} 756 757 758static int 759p_nonground2(value val, type tag, value vvar, type tvar) 760{ 761 pword *pw; 762 763 if (pw = ec_nonground(val, tag)) 764 { 765 Return_Unify_Pw(vvar, tvar, pw->val, pw->tag); 766 } 767 else 768 { 769 Fail_; 770 } 771} 772 773 774/* 775 * Build a list of <vars_needed> distinct variables in the term val/tag. 776 * The return value is <vars_needed> minus the number of variables found. 777 * Already encountered variables are marked by a trailed binding to [], 778 * Therefore untrailing is needed after a call to _collect_vars(). 779 * 780 * Handling of cyclic terms: 781 * Direct cycles (like X=f(X)) are directly tested for. 782 * Indirect cycles: these contain at least 2 compound terms. One of the 783 * compound terms in a cycle is the one with the lowest address. It must 784 * therefore be reached by a downward pointer from the previous, and it 785 * must contain an upward pointer to the next compound term in the cycle. 786 * We detect this situation and mark the upward pointer (by overwriting 787 * it with []). This will stop traversal on the next encounter. 788 */ 789 790#define InGlobalStack(p) (TG_ORIG <= (p) && (p) < TG) 791 792static int 793_collect_vars( 794 value val, type tag, /* current term */ 795 word vars_needed, /* >0, number of variables to collect */ 796 pword *last_comp, /* previously encountered compound term (or NULL) */ 797 pword *curr_comp, /* compound term being processed now (or NULL) */ 798 pword *from, /* address of val:tag */ 799 int elem_sz) /* array (1) or list (2) result */ 800{ 801 word arity; 802 pword *next_comp; 803 804 for (;;) 805 { 806 if (IsRef(tag)) 807 { 808 pword *el = TG; 809 TG += elem_sz; 810 Check_Gc; 811 Make_Ref(el, val.ptr); 812 if (IsVar(tag)) /* mark the variable */ 813 { Trail_(val.ptr) } 814 else 815 { Trail_Tag(val.ptr) } 816 val.ptr->tag.kernel = TNIL; 817 return vars_needed-1; 818 } 819 else if (IsList(tag)) 820 { 821 arity = 2; 822 next_comp = val.ptr; 823 } 824 else if (IsStructure(tag)) 825 { 826 arity = DidArity(val.ptr->val.did); 827 next_comp = val.ptr++; 828 } 829 else 830 return vars_needed; 831 832 /* Assume non-stack terms are ground. This also stops us from 833 * modifying immutable shared heap terms by marking. */ 834 if (!InGlobalStack(val.ptr)) 835 return vars_needed; 836 837 /* direct recursion? */ 838 if (next_comp == curr_comp) 839 return vars_needed; 840 841 /* Are we changing direction (from going down to going up)? */ 842 if (next_comp > curr_comp && curr_comp < last_comp) 843 { 844 Trail_Word(from, 1, TRAILED_WORD32); 845 from->tag.kernel = TNIL; /* mark to prevent looping */ 846 } 847 848 for(;arity > 1; arity--) 849 { 850 pword *arg_i = val.ptr++; 851 Dereference_(arg_i); 852 if (!ISAtomic(arg_i->tag.kernel)) 853 { 854 vars_needed = _collect_vars(arg_i->val, arg_i->tag, vars_needed, 855 curr_comp, next_comp, arg_i, elem_sz); 856 if (vars_needed == 0) 857 return vars_needed; 858 } 859 } 860 from = val.ptr; /* tail recursion */ 861 Dereference_(from); 862 last_comp = curr_comp; 863 curr_comp = next_comp; 864 val.all = from->val.all; 865 tag.all = from->tag.all; 866 } 867} 868 869 870static int 871p_nonground3(value vn, type tn, value vterm, type tterm, value vlist, type tlst) 872{ 873 pword list; 874 pword **old_tt = TT; 875 876 Check_Integer(tn) 877 Check_Output_List(tlst) 878 if (vn.nint <= 0) 879 { Bip_Error(RANGE_ERROR); } 880 881 Make_List(&list, TG); 882 if (_collect_vars(vterm, tterm, vn.nint, 0, 0, 0, 2) != 0) { 883 Fail_; /* not enough variables found */ 884 } 885 { 886 pword *pw; 887#define TERM_VARIABLES_BACKWARD 888#ifdef TERM_VARIABLES_BACKWARD 889 for(pw = TG-1; pw>list.val.ptr+2; pw-=2) { 890 Make_List(pw, pw-3); 891 } 892 list.val.ptr = TG-2; 893#else 894 for(pw = list.val.ptr+1; pw<TG-2; pw+=2) { 895 Make_List(pw, pw+1); 896 } 897#endif 898 Make_Nil(pw); 899 } 900 Untrail_Variables(old_tt); 901 Return_Unify_List(vlist, tlst, list.val.ptr) 902} 903 904 905static int 906p_term_variables_rl(value vterm, type tterm, value vlist, type tlst) 907{ 908 pword list; 909 pword **old_tt = TT; 910 911 Check_Output_List(tlst) 912 913 Make_List(&list, TG); 914 (void) _collect_vars(vterm, tterm, MAX_S_WORD, 0, 0, 0, 2); 915 if (TG == list.val.ptr) { 916 Make_Nil(&list); 917 } else { 918 pword *pw; 919 for(pw = TG-1; pw>list.val.ptr+2; pw-=2) { 920 Make_List(pw, pw-3); 921 } 922 list.val.ptr = TG-2; 923 Make_Nil(pw); 924 } 925 Untrail_Variables(old_tt); 926 Return_Unify_Pw(vlist, tlst, list.val, list.tag) 927} 928 929 930static int 931p_term_variables_lr(value vterm, type tterm, value vlist, type tlst) 932{ 933 pword list; 934 pword **old_tt = TT; 935 936 Check_Output_List(tlst) 937 938 Make_List(&list, TG); 939 (void) _collect_vars(vterm, tterm, MAX_S_WORD, 0, 0, 0, 2); 940 if (TG == list.val.ptr) { 941 Make_Nil(&list); 942 } else { 943 pword *pw; 944 for(pw = list.val.ptr+1; pw<TG-2; pw+=2) { 945 Make_List(pw, pw+1); 946 } 947 Make_Nil(pw); 948 } 949 Untrail_Variables(old_tt); 950 Return_Unify_Pw(vlist, tlst, list.val, list.tag) 951} 952 953 954static int 955p_term_variables_array(value vterm, type tterm, value varr, type tarr) 956{ 957 pword *old_tg = TG++; /* leave space for array functor */ 958 pword **old_tt = TT; 959 pword result; 960 961 (void) _collect_vars(vterm, tterm, MAX_S_WORD, 0, 0, 0, 1); 962 if (TG > old_tg+1) { 963 Make_Atom(old_tg, add_dict(d_.nil, TG-old_tg-1)); 964 Make_Struct(&result, old_tg); 965 } else { 966 TG = old_tg; /* no array needed */ 967 Make_Nil(&result); 968 } 969 Untrail_Variables(old_tt); 970 Return_Unify_Pw(varr, tarr, result.val, result.tag) 971} 972 973 974 975/* 976 * Change all variables in a term to TUNIVs 977 */ 978 979static int 980_setuniv(value v, type t) 981{ 982 register int arity, err; 983 984 for(;;) /* tail recursion loop */ 985 { 986 switch (TagType(t)) 987 { 988 case TVAR_TAG: 989 { 990 register pword *pw = v.ptr; 991 Trail_If_Needed(pw); 992 if (pw > Gbl_Tg) /* if local, globalize first */ 993 { 994 pw = Gbl_Tg++; 995 Check_Gc; 996 v.ptr->val.ptr = pw->val.ptr = pw; 997 } 998 pw->tag.kernel = RefTag(TUNIV); 999 Succeed_; 1000 } 1001 case TNAME: 1002 Trail_Tag_If_Needed_Gb(v.ptr); 1003 v.ptr->tag.kernel = TagNameField(t.kernel) | RefTag(TUNIV); 1004 Succeed_; 1005 case TUNIV: 1006 /* there may be duplicates in the argument, that is not wrong */ 1007 Succeed_; 1008 1009 case TMETA: 1010 /* this depends on whether the attribute implies a constraint */ 1011 Succeed_; /* ? */ 1012 1013 case TLIST: 1014 arity = 2; 1015 break; 1016 case TCOMP: 1017 arity = DidArity(v.ptr->val.did); 1018 v.ptr++; 1019 break; 1020 1021 default: 1022 Succeed_; 1023 } 1024 1025 for (; arity > 1; arity--) 1026 { 1027 pword *next = v.ptr++; 1028 Dereference_(next); 1029 if (err = _setuniv(next->val, next->tag)) 1030 Bip_Error(err); 1031 } 1032 Dereference_(v.ptr); /* tail recursion optimised */ 1033 t.all = v.ptr->tag.all; 1034 v.all = v.ptr->val.all; 1035 } 1036} 1037 1038static int 1039p_setuniv(value v, type t) 1040{ 1041 if (IsRef(t)) 1042 return(_setuniv(v, v.ptr->tag)); /* needed due to Puts_named_variable */ 1043 else 1044 return(_setuniv(v, t)); 1045} 1046 1047/* Destructively replace the attribute of a metaterm. This allows 1048 * more efficient trailing than to replace the element of the 1049 * metaterm structure. 1050 */ 1051static int 1052p_replace_attribute(value vmeta, type tmeta, value vterm, type tterm, value vm, type tm) 1053{ 1054 return modify_attribute(vmeta, tmeta, vterm, tterm, vm, tm, 1); 1055} 1056 1057/* 1058 * Add an attribute to a variable. Unless it is already hard there, 1059 * we just supply the new data, otherwise the handler is invoked 1060 * to merge the two attributes. 1061 */ 1062static int 1063p_add_attribute(value vv, type tv, value va, type ta, value vm, type tm) 1064{ 1065 return modify_attribute(vv, tv, va, ta, vm, tm, 0); 1066} 1067 1068static int 1069modify_attribute(value vv, type tv, value va, type ta, value vm, type tm, int replace) 1070{ 1071 int slot; 1072 pword *var; 1073 pword *attr; 1074 pword *mt; 1075 pword *nva; 1076 word nta; 1077 1078 if (IsInteger(tm)) 1079 { 1080 slot = vm.nint; 1081 if (slot <= 0 || slot > p_meta_arity_->val.nint) { 1082 return(RANGE_ERROR); 1083 } 1084 } 1085 else if (IsAtom(tm)) 1086 { 1087 slot = meta_index(vm.did); 1088 if (slot == 0) { 1089 return(UNDEF_ATTR); 1090 } 1091 } 1092 else { 1093 return(TYPE_ERROR); 1094 } 1095 if (IsVar(ta) && va.ptr > TG) { /* a local variable */ 1096 attr = TG++; 1097 Check_Gc; 1098 attr->val.ptr = attr; 1099 attr->tag.kernel = TREF; 1100 Bind_(va.ptr, attr->val.ptr, attr->tag.kernel); 1101 nva = attr->val.ptr; 1102 nta = attr->tag.kernel; 1103 } else { 1104 nva = va.ptr; 1105 nta = ta.kernel; 1106 } 1107 if (IsMeta(tv)) { 1108 int i, arity; 1109 1110 var = MetaTerm(vv.ptr); 1111 Dereference_(var); 1112 var = var->val.ptr; 1113 if ((arity = DidArity(var->val.did)) < slot) { 1114 /* we must increase the attribute size */ 1115 1116 mt = add_attribute(tv.kernel, nva, nta, slot); 1117 /* copy the other attributes */ 1118 attr = MetaTerm(mt)->val.ptr; 1119 for (i = 1; i <= arity; i++) 1120 attr[i] = var[i]; 1121 var = MetaTerm(vv.ptr); 1122 if (vv.ptr < GB && !NewLocation(var->val.ptr)) { 1123 Trail_Pword(var); 1124 } 1125 var->val.ptr = attr; 1126 var->tag.kernel = TCOMP; 1127 return PSUCCEED; 1128 } 1129 var += slot; 1130 if (replace) { 1131 /* this code is a specialisation of ec_assign() */ 1132 if (!NewLocation(var) && !NewValue(var->val, var->tag)) 1133 { 1134 Trail_Pword(var); 1135 } 1136 var->tag.kernel = nta; 1137 var->val.ptr = nva; 1138 return PSUCCEED; 1139 } else { 1140 Dereference_(var); 1141 if (IsVar(var->tag) || IsName(var->tag)) { 1142 /* insert the attribute into an existing empty slot */ 1143 Return_Unify_Pw(var->val, var->tag, va, ta); 1144 } else { 1145 /* the slot is not empty, let the handler handle it */ 1146 mt = add_attribute(TREF, nva, nta, slot); 1147 Return_Unify_Pw(vv, tv, mt->val, mt->tag); 1148 } 1149 } 1150 } else if (IsVar(tv) || IsName(tv)) { 1151 /* bind the free variable to a fresh metaterm */ 1152 mt = add_attribute(tv.kernel, nva, nta, slot); 1153 Return_Unify_Pw(vv, tv, mt->val, tref); 1154 } else { 1155 if (replace) 1156 return TYPE_ERROR; 1157 /* a nonvariable, let the handler handle it */ 1158 mt = add_attribute(TREF, nva, nta, slot); 1159 Return_Unify_Pw(vv, tv, mt->val, mt->tag); 1160 } 1161} 1162 1163static pword * 1164get_attribute(value vv, type tv, value vm, type tm, int *err) 1165{ 1166 int slot; 1167 pword *var; 1168 1169 if (IsInteger(tm)) 1170 { 1171 slot = vm.nint; 1172 if (slot <= 0 || slot > p_meta_arity_->val.nint) { 1173 *err = RANGE_ERROR; 1174 return 0; 1175 } 1176 } 1177 else if (IsAtom(tm)) 1178 { 1179 slot = meta_index(vm.did); 1180 if (slot == 0) { 1181 *err = UNDEF_ATTR; 1182 return 0; 1183 } 1184 } 1185 else { 1186 *err = TYPE_ERROR; 1187 return 0; 1188 } 1189 if (IsMeta(tv)) { 1190 var = MetaTerm(vv.ptr); 1191 Dereference_(var); 1192 var = var->val.ptr; 1193 if (DidArity(var->val.did) < slot) { 1194 *err = PFAIL; 1195 return 0; 1196 } 1197 var += slot; 1198 Dereference_(var); 1199 return var; 1200 } else if (IsVar(tv) || IsName(tv)) { 1201 *err = PFAIL; 1202 return 0; 1203 } else { 1204 *err = TYPE_ERROR; 1205 return 0; 1206 } 1207} 1208 1209/* 1210 * Return the given attribute, for completeness only. 1211 */ 1212static int 1213p_get_attribute(value vv, type tv, value va, type ta, value vm, type tm) 1214{ 1215 pword *var; 1216 int err; 1217 1218 var = get_attribute(vv, tv, vm, tm, &err); 1219 if (var == 0) { 1220 if (err == PFAIL) { 1221 Fail_; 1222 } else { 1223 Bip_Error(err); 1224 } 1225 } 1226 Return_Unify_Pw(va, ta, var->val, var->tag) 1227} 1228 1229/* 1230 * SICStus-like $get_attributes/3 1231 */ 1232static int 1233p_get_attributes(value vv, type tv, value va, type ta, value vm, type tm, value vmod, type tmod) 1234{ 1235 pword *var; 1236 pword *mask; 1237 int err; 1238 Prepare_Requests; 1239 1240 var = get_attribute(vv, tv, vmod, tmod, &err); 1241 if (var == 0) { 1242 if (err == PFAIL) { 1243 Request_Unify_Integer(vm, tm, 0) 1244 Return_Unify; 1245 } else { 1246 Bip_Error(err); 1247 } 1248 } 1249 if (IsRef(var->tag)) { 1250 Request_Unify_Integer(vm, tm, 0) 1251 } else if (IsStructure(var->tag)) { 1252 mask = var->val.ptr + 1; 1253 Dereference_(mask); 1254 Request_Unify_Pw(va, ta, var->val, var->tag) 1255 Request_Unify_Integer(vm, tm, mask->val.nint) 1256 } 1257 Return_Unify; 1258} 1259 1260/* 1261 * undo_meta_bind(Pair, AttrVar) 1262 * Undo the binding before the pre-unification handler is called. 1263 */ 1264/*ARGSUSED*/ 1265static int 1266p_undo_meta_bind(value vp, type tp, value vv, type tv) 1267{ 1268 vp.ptr->tag.kernel = RefTag(TMETA); 1269 vp.ptr->val.ptr = vp.ptr; 1270 Return_Unify_Pw(vv, tv, vp, tref); 1271} 1272 1273/* 1274 * do_meta_bind(Pair, Term) 1275 * Do the binding after the pre-unification handler is called. 1276 */ 1277/*ARGSUSED*/ 1278static int 1279p_do_meta_bind(value vp, type tp, value vt, type tt) 1280{ 1281 vp.ptr->val.all = vt.all; 1282 vp.ptr->tag.all = tt.all; 1283 Succeed_; 1284} 1285 1286/* 1287 * set_suspension_number(Susp, N) 1288 * Set the invocation number of a suspension. The debugger uses positive 1289 * numbers and this predicate uses the negative ones to make the difference. 1290 */ 1291static int 1292p_set_suspension_number(value vs, type ts, value vn, type tn) 1293{ 1294 Check_Type(ts, TSUSP) 1295 Check_Integer(tn) 1296 if (vn.nint < 0) { 1297 Bip_Error(RANGE_ERROR) 1298 } 1299 if (ValidInvoc(SuspDebugInvoc(vs.ptr))) { 1300 Fail_; 1301 } 1302 SuspDebugInvoc(vs.ptr) = -vn.nint; 1303 Succeed_; 1304} 1305 1306/* 1307 * get_suspension_number(Susp, N) 1308 * Return the invoc of the suspension, fail if it has a debug invoc. 1309 */ 1310static int 1311p_get_suspension_number(value vs, type ts, value vn, type tn) 1312{ 1313 word n; 1314 1315 Check_Type(ts, TSUSP) 1316 Check_Output_Integer(tn) 1317 if ((n = SuspDebugInvoc(vs.ptr)) > 0) { 1318 Fail_; 1319 } 1320 Return_Unify_Integer(vn, tn, -n) 1321} 1322 1323static int 1324p_get_suspension_data(value vs, type ts, value vwhat, type twhat, value v, type t) 1325{ 1326 Check_Output_Type(ts, TSUSP) 1327 Check_Atom(twhat); 1328 if (IsRef(ts)) 1329 { Fail_; } 1330 if (vwhat.did == d_.state) 1331 { 1332 word n = vs.ptr < LD_END ? -1 1333 : SuspDead(vs.ptr) ? 2 1334 : SuspScheduled(vs.ptr) ? 1 1335 : 0; 1336 Return_Unify_Integer(v, t, n); 1337 } 1338 if (SuspDead(vs.ptr)) 1339 { Fail_; } 1340 if (vwhat.did == d_.priority) 1341 { 1342 Return_Unify_Integer(v, t, SuspPrio(vs.ptr)) 1343 } 1344 else if (vwhat.did == d_.invoc) 1345 { 1346 Return_Unify_Integer(v, t, SuspDebugInvoc(vs.ptr)) 1347 } 1348 else if (vwhat.did == d_.goal) 1349 { 1350 Return_Unify_Pw(v, t, vs.ptr[SUSP_GOAL].val, vs.ptr[SUSP_GOAL].tag); 1351 } 1352 else if (vwhat.did == d_.module0) 1353 { 1354 Return_Unify_Pw(v, t, vs.ptr[SUSP_MODULE].val, vs.ptr[SUSP_MODULE].tag); 1355 } 1356 else if (vwhat.did == d_.spy) 1357 { 1358 Return_Unify_Atom(v, t, PriFlags(SuspProc(vs.ptr)) & DEBUG_SP ? d_.on : d_.off); 1359 } 1360 else if (vwhat.did == d_.skip) 1361 { 1362 Return_Unify_Atom(v, t, PriFlags(SuspProc(vs.ptr)) & DEBUG_SK ? d_.on : d_.off); 1363 } 1364 else if (vwhat.did == d_qualified_goal_) 1365 { 1366 pword *pw = TG; 1367 Push_Struct_Frame(d_.colon); 1368 Make_Atom(&pw[1], PriModule(SuspProc(vs.ptr))); 1369 pw[2] = vs.ptr[SUSP_GOAL]; 1370 Return_Unify_Structure(v, t, pw); 1371 } 1372 Bip_Error(RANGE_ERROR); 1373} 1374 1375static int 1376p_set_suspension_data(value vs, type ts, value vwhat, type twhat, value v, type t) 1377{ 1378 Check_Output_Type(ts, TSUSP) 1379 Check_Atom(twhat); 1380 Check_Integer(t); 1381 if (IsRef(ts) || SuspDead(vs.ptr)) /* ignore if dead/nonexistent */ 1382 { Succeed_; } 1383 if (vwhat.did == d_.priority) 1384 { 1385 if (SuspPrio(vs.ptr) != v.nint) 1386 { 1387 if (v.nint < 1 || v.nint > SUSP_MAX_PRIO) 1388 { Bip_Error(RANGE_ERROR); } 1389 Set_Susp_Prio(vs.ptr, v.nint); 1390 } 1391 } 1392 else if (vwhat.did == d_.invoc) 1393 { 1394 SuspDebugInvoc(vs.ptr) = v.nint; 1395 } 1396 else { Bip_Error(RANGE_ERROR); } 1397 Succeed_; 1398} 1399 1400 1401/* 1402 * set_suspension_arg(+Suspension, +Index, +Argument) 1403 * same as 1404 * get_suspension_data(Susp, goal, Goal), setarg(Index, Goal, Argument) 1405 */ 1406 1407static int 1408p_set_suspension_arg(value vs, type ts, value vn, type tn, value va, type ta) 1409{ 1410 pword *argp; 1411 word arity; 1412 1413 Check_Type(ts, TSUSP) 1414 Check_Integer(tn); 1415 1416 /* 1417 * This should better be an error rather than failure. 1418 * For dead suspensions definitely, for scheduled ones probably... 1419 */ 1420 if (SuspDead(vs.ptr)) 1421 { Fail_; } 1422 1423 if (IsStructure(vs.ptr[SUSP_GOAL].tag)) 1424 { 1425 argp = vs.ptr[SUSP_GOAL].val.ptr; 1426 arity = DidArity(argp->val.did); 1427 } 1428 else if (IsList(vs.ptr[SUSP_GOAL].tag)) 1429 { 1430 argp = vs.ptr[SUSP_GOAL].val.ptr - 1; 1431 arity = 2; 1432 } 1433 else 1434 { 1435 Bip_Error(IsRef(vs.ptr[SUSP_GOAL].tag) ? INSTANTIATION_FAULT : TYPE_ERROR); 1436 } 1437 if (vn.nint < 1 || vn.nint > arity) 1438 { 1439 Bip_Error(RANGE_ERROR); 1440 } 1441 argp += vn.nint; 1442 return ec_assign(argp, va, ta); /* succeeds */ 1443} 1444 1445 1446/* 1447 * Distribute the suspensions in the list to the global woken lists 1448 */ 1449int 1450p_schedule_woken(value vl, type tl) 1451{ 1452 register pword *p, *next; 1453 1454 if (IsStructure(tl) && vl.ptr->val.did == d_.minus) { 1455 next = vl.ptr + 1; 1456 Dereference_(next); 1457 if (IsList(next->tag)) 1458 next = next->val.ptr; 1459 else if (IsRef(next->tag)) { 1460 Succeed_ 1461 } else { 1462 Bip_Error(TYPE_ERROR) 1463 } 1464 } else if (IsList(tl)) 1465 next = vl.ptr; 1466 else if (IsNil(tl) || IsRef(tl)) { 1467 Succeed_ 1468 } else { 1469 Bip_Error(TYPE_ERROR) 1470 } 1471 1472 /* simplified version of ec_schedule_susps without 1473 * list cleanup (since the list is not needed anymore). 1474 */ 1475 for (;;) 1476 { 1477 p = next++; 1478 Dereference_(p); 1479 if (!IsTag(p->tag.kernel, TSUSP)) { 1480 Bip_Error(TYPE_ERROR) 1481 } 1482 p = p->val.ptr; 1483 1484 if (!SuspDead(p) && !SuspScheduled(p)) 1485 { 1486 /* schedule this suspension (it may already be in WL!) */ 1487 if (!SuspInWL(p)) 1488 { 1489 pword *q = WLFirst(WL) + SuspPrio(p) - 1; 1490 pword *new = TG; 1491 Push_List_Frame() 1492 Make_Susp(&new[0], p); 1493 new[1] = *q; 1494 if (IsNil(q->tag) || q->val.ptr < GB) { 1495 Trail_Pword(q) 1496 } 1497 Make_List(q, new); 1498 } 1499 Set_Susp_Scheduled(p); 1500 } 1501 Dereference_(next); 1502 if (!IsList(next->tag)) { 1503 Succeed_ 1504 } 1505 next = next->val.ptr; 1506 } 1507} 1508 1509 1510/* 1511 * get_postponed(-EventStruct) 1512 * return the postponed goals structure es(postponed, Susps) 1513 * 1514 * get_postponed_nonempty(-EventStruct) 1515 * return the postponed goals structure es(postponed, Susps) 1516 * if Susps is not empty, and reinitialise to es(postponed, []). 1517 * If Susps is empty, fail. 1518 * 1519 * reinit_postponed(-OldSusps) 1520 * return the postponed suspension list and reinitialise. 1521 * 1522 * reset_postponed(+OldSusps) 1523 * reset the postponed suspension list to the given old value. 1524 */ 1525int 1526ec_init_postponed(void) 1527{ 1528 pword *pw = TG; 1529 Push_Struct_Frame(d_es_2_); 1530 Make_Atom(pw+1, d_postponed_); 1531 Make_Nil(pw+2); 1532 Make_Struct(&PostponedList, pw); 1533 Succeed_; 1534} 1535 1536static int 1537p_get_postponed(value v, type t) 1538{ 1539 Bind_(v.ptr, PostponedList.val.ptr, PostponedList.tag.kernel); 1540 Succeed_; 1541} 1542 1543static int 1544p_get_postponed_nonempty(value v, type t) 1545{ 1546 int result; 1547 pword new_struct; 1548 1549 pword *pw = &PostponedList.val.ptr[2]; /* fail if list empty */ 1550 Dereference_(pw); 1551 if (IsNil(pw->tag)) 1552 { Fail_; } 1553 /* return nonempty one */ 1554 Bind_(v.ptr, PostponedList.val.ptr, PostponedList.tag.kernel); 1555 1556 pw = TG; /* reinitialise */ 1557 Push_Struct_Frame(d_es_2_); 1558 Make_Atom(pw+1, d_postponed_); 1559 /*Make_Nil(pw+2);*/ 1560 Make_Stamp(pw+2); /* a timestamped [] */ 1561 Make_Struct(&new_struct, pw); 1562 return ec_assign(&PostponedList, new_struct.val, new_struct.tag); 1563} 1564 1565static int 1566p_reinit_postponed(value vold, type told) 1567{ 1568 pword *pw = &PostponedList.val.ptr[2]; /* return old suspension list */ 1569 Bind_(vold.ptr, pw->val.ptr, pw->tag.kernel); 1570 Dereference_(pw); 1571 if (!IsNil(pw->tag)) /* reinitialise */ 1572 { 1573 pword empty; 1574 Make_Stamp(&empty); /* a timestamped [] */ 1575 ec_assign(pw, empty.val, empty.tag); 1576 } 1577 Succeed_; 1578} 1579 1580static int 1581p_reset_postponed(value vold, type told) 1582{ 1583 /* we expect that the postponed list is already empty at this point */ 1584#ifdef PRINTAM 1585 pword *pw = &PostponedList.val.ptr[2]; 1586 Dereference_(pw); 1587 if (!IsNil(pw->tag)) 1588 { 1589 p_fprintf(current_err_, "ECLiPSe kernel warning: postponed list not empty in reset_postponed/1"); 1590 ec_flush(current_err_); 1591 } 1592#endif 1593 if (!IsNil(told)) /* reset if necessary */ 1594 { 1595 return ec_assign(&PostponedList.val.ptr[2], vold, told); 1596 } 1597 Succeed_; 1598} 1599 1600 1601/* 1602 * postpone_suspensions(+Pos, +Attr) 1603 * Put a whole suspension list into the global postponed-list 1604 */ 1605 1606int 1607p_postpone_suspensions(value vpos, type tpos, value vattr, type tattr) 1608{ 1609 Check_Integer(tpos); 1610 Check_Structure(tattr); 1611 if (vpos.nint < 1 || vpos.nint > DidArity(vattr.ptr->val.did)) 1612 { 1613 Bip_Error(RANGE_ERROR); 1614 } 1615 return p_schedule_postponed(vattr.ptr[vpos.nint].val, vattr.ptr[vpos.nint].tag); 1616} 1617 1618 1619int 1620p_schedule_postponed(value vl, type tl) 1621{ 1622 pword *p, *next, *ppp; 1623 pword newpp; 1624 int change = 0; 1625 1626 if (IsStructure(tl) && vl.ptr->val.did == d_.minus) { 1627 next = vl.ptr + 1; 1628 Dereference_(next); 1629 if (IsList(next->tag)) 1630 next = next->val.ptr; 1631 else if (IsRef(next->tag)) { 1632 Succeed_ 1633 } else { 1634 Bip_Error(TYPE_ERROR) 1635 } 1636 } else if (IsList(tl)) 1637 next = vl.ptr; 1638 else if (IsNil(tl) || IsRef(tl)) { 1639 Succeed_ 1640 } else { 1641 Bip_Error(TYPE_ERROR) 1642 } 1643 1644 /* Partial garbage collection: remove dead stuff at the 1645 * beginning of the postponed-list 1646 */ 1647 ppp = &PostponedList.val.ptr[2]; 1648 Dereference_(ppp); 1649 newpp = *ppp; 1650 while (IsList(ppp->tag)) 1651 { 1652 ppp = ppp->val.ptr; 1653 p = ppp++; 1654 Dereference_(p); 1655 if (!IsTag(p->tag.kernel, TSUSP)) { 1656 Bip_Error(TYPE_ERROR) 1657 } 1658 p = p->val.ptr; 1659 /* This if peculiar to the postponed-list: we can remove scheduled 1660 * suspensions (even if demons) because the list will never be 1661 * woken twice (it is scrapped after having been woken). 1662 */ 1663 if (!SuspDead(p) && !SuspScheduled(p)) 1664 break; 1665 Dereference_(ppp); 1666 newpp = *ppp; 1667 change = 1; 1668 } 1669 1670 /* Move live suspensions to the postponed-list. 1671 * No input list cleanup (since the list is not needed anymore). 1672 */ 1673 for (;;) 1674 { 1675 p = next++; 1676 Dereference_(p); 1677 if (!IsTag(p->tag.kernel, TSUSP)) { 1678 Bip_Error(TYPE_ERROR) 1679 } 1680 p = p->val.ptr; 1681 1682 /* This if peculiar to the postponed-list: no need to move an 1683 * already scheduled suspension there, because the rationale 1684 * of the postponed list is only to guarantee (one) future waking. 1685 */ 1686 if (!SuspDead(p) && !SuspScheduled(p)) 1687 { 1688 pword *new = TG; 1689 Push_List_Frame() 1690 Make_Susp(&new[0], p); 1691 new[1] = newpp; 1692 Make_List(&newpp, new); 1693 change = 1; 1694 } 1695 Dereference_(next); 1696 if (!IsList(next->tag)) { 1697 break; 1698 } 1699 next = next->val.ptr; 1700 } 1701 1702 if (change) 1703 ec_assign(&PostponedList.val.ptr[2], newpp.val, newpp.tag); 1704 Succeed_ 1705} 1706 1707 1708/* 1709 * Demon-aware suspension lists: 1710 * 1711 * init_suspension_list(+Pos, +Attr) 1712 * enter_suspension_list(+Pos, +Attr, +Susp) 1713 * merge_suspension_lists(+Pos1, +Attr1, +Pos2, +Attr2) 1714 * schedule_suspensions(+Pos, +Attr) 1715 * 1716 * If these lists were guaranteed to only ever get manipulated by 1717 * special procedures, we could get rid of all the dereferencing. 1718 */ 1719 1720#define SUSP_LIST_CLEANUP 1721 1722static 1723int 1724p_init_suspension_list(value vpos, type tpos, value vattr, type tattr) 1725{ 1726 pword *arg; 1727 Check_Integer(tpos); 1728 Check_Structure(tattr); 1729 if (vpos.nint < 1 || vpos.nint > DidArity(vattr.ptr->val.did)) 1730 { 1731 Bip_Error(RANGE_ERROR); 1732 } 1733 arg = &vattr.ptr[vpos.nint]; 1734 Dereference_(arg); 1735 Check_Ref(arg->tag); 1736 Return_Bind_Var(arg->val, arg->tag, 0, TNIL); 1737} 1738 1739/* 1740 * enter_suspension_list(+Positiion, +Attribute, +Suspension) 1741 */ 1742static int 1743p_enter_suspension_list(value vn, type tn, value vatt, type tatt, value vsusp, type tsusp) 1744{ 1745 pword *susp, *att; 1746 int res; 1747 1748 Check_Integer(tn); 1749 Check_Structure(tatt); 1750 1751 Get_Suspension(vsusp, tsusp, susp) 1752 att = vatt.ptr; 1753 if ((int) vn.nint <= 0 || DidArity(att->val.did) < (int) vn.nint) { 1754 Bip_Error(RANGE_ERROR); 1755 } 1756 res = ec_enter_suspension(att + (int) vn.nint, susp); 1757 if (res < 0) { 1758 Bip_Error(res); 1759 } 1760 Succeed_; 1761} 1762 1763 1764/* 1765 * merge_suspension_lists(+Pos1, +Attr1, +Pos2, +Attr2) 1766 * 1767 * Destructively append list1 (argument Pos1 of Attr1) to 1768 * the end of list2 (argument Pos2 of Attr2). 1769 * Currently neither cleanup nor duplicate removal. 1770 */ 1771int 1772p_merge_suspension_lists(value vpos1, type tpos1, value vattr1, type tattr1, value vpos2, type tpos2, value vattr2, type tattr2) 1773{ 1774 pword *list1, *list2; 1775 pword *last; 1776 Check_Integer(tpos1); 1777 Check_Integer(tpos2); 1778 Check_Structure(tattr1); 1779 Check_Structure(tattr2); 1780 if (vpos1.nint < 1 || vpos1.nint > DidArity(vattr1.ptr->val.did) 1781 || vpos2.nint < 1 || vpos2.nint > DidArity(vattr2.ptr->val.did)) 1782 { 1783 Bip_Error(RANGE_ERROR); 1784 } 1785 last = list2 = &vattr2.ptr[vpos2.nint]; 1786 Dereference_(list2); 1787 if (IsList(list2->tag)) /* find the end of list2 */ 1788 { 1789 list2 = list2->val.ptr; 1790 for (;;) 1791 { 1792 last = ++list2; 1793 Dereference_(list2); 1794 if (!IsList(list2->tag)) 1795 break; 1796 list2 = list2->val.ptr; 1797 } 1798 } 1799 if (!IsNil(list2->tag)) 1800 { 1801 Bip_Error(TYPE_ERROR) 1802 } 1803 /* last now points to the end of list2 */ 1804 1805 list1 = &vattr1.ptr[vpos1.nint]; /* append list1 */ 1806 Dereference_(list1); 1807 if (IsList(list1->tag)) 1808 { 1809 list1 = list1->val.ptr; 1810 if (last < GB) { 1811 Trail_Pword(last) /* trail the [] */ 1812 } 1813 Make_List(last, list1); 1814 } 1815 else if (!IsNil(list1->tag)) 1816 { 1817 Bip_Error(TYPE_ERROR) 1818 } 1819 Succeed_; 1820} 1821 1822 1823/* 1824 * ec_schedule_susp(+Susp) 1825 * 1826 * Schedule a suspension for waking. Susp should be the val pointer from 1827 * the TSUSP cell, not a pointer to the TSUSP cell. 1828 */ 1829 1830int 1831ec_schedule_susp(pword *susp) 1832{ 1833 if (!SuspDead(susp) && !SuspScheduled(susp)) 1834 { 1835 /* schedule this suspension (it may already be in WL!) */ 1836 if (!SuspInWL(susp)) 1837 { 1838 pword *q = WLFirst(WL) + SuspPrio(susp) - 1; 1839 pword *new = TG; 1840 Push_List_Frame() 1841 Make_Susp(&new[0], susp); 1842 new[1] = *q; 1843 if (IsNil(q->tag) || q->val.ptr < GB) { 1844 Trail_Pword(q) 1845 } 1846 Make_List(q, new); 1847 } 1848 Set_Susp_Scheduled(susp); 1849 } 1850 Succeed_ 1851} 1852 1853 1854/* 1855 * schedule_suspensions(+Pos, +Attr) 1856 * 1857 * Schedule a suspension list (argument Pos of Attr) for waking. 1858 * All so far unscheduled suspensions are put into the woken lists 1859 * according to their priority. The input list is cleaned up, 1860 * only live demons remain in it. 1861 */ 1862 1863int 1864ec_schedule_susps(pword *next) 1865{ 1866 pword *last_live, *p; 1867 int found_dead = 0; 1868 1869 last_live = next; 1870 Dereference_(next); 1871 if (IsList(next->tag)) { 1872 next = next->val.ptr; 1873 } else if (IsNil(next->tag) || IsRef(next->tag)) { 1874 Succeed_ 1875 } else { 1876 Bip_Error(TYPE_ERROR) 1877 } 1878 1879 for (;;) 1880 { 1881 p = next; /* get the suspension */ 1882 Dereference_(p); 1883 if (!IsTag(p->tag.kernel, TSUSP)) { 1884 Bip_Error(TYPE_ERROR) 1885 } 1886 p = p->val.ptr; 1887 1888 if (!SuspDead(p) && !SuspScheduled(p)) 1889 { 1890 /* schedule this suspension (it may already be in WL!) */ 1891 if (!SuspInWL(p)) 1892 { 1893 pword *q = WLFirst(WL) + SuspPrio(p) - 1; 1894#ifdef SCHEDULE_FIFO 1895 pword *new = TG; 1896 if (q->val.ptr < GB) { 1897 Trail_Pword(q) 1898 } 1899 if (IsTag(q->tag.kernel, TLIST)) { 1900 pword *last = q->val.ptr + 1; 1901 Make_List(q, new); 1902 if (!ISPointer(last->tag.kernel)) (void) ec_panic("Illegal WL", "schedule_woken()"); 1903 if (last->val.ptr < GB) { 1904 Trail_Pword(q) 1905 } 1906 q = last->val.ptr; /* first elememt */ 1907 Make_List(last, new); 1908 Push_List_Frame() 1909 Make_Susp(&new[0], p); 1910 Make_List(new+1, q); 1911 } else { 1912 if (!IsRef(q->tag)) (void) ec_panic("Illegal WL", "schedule_woken()"); 1913 Make_List(q, new); 1914 Push_List_Frame() 1915 Make_Susp(&new[0], p); 1916 Make_List(new+1, new); 1917 } 1918#else 1919 pword *new = TG; 1920 Push_List_Frame() 1921 Make_Susp(&new[0], p); 1922 new[1] = *q; 1923 if (IsNil(q->tag) || q->val.ptr < GB) { 1924 Trail_Pword(q) 1925 } 1926 Make_List(q, new); 1927#endif 1928 } 1929 Set_Susp_Scheduled(p); 1930 } 1931 1932#ifdef SUSP_LIST_CLEANUP 1933 if (SuspDead(p) || !SuspDemon(p)) 1934 { 1935 found_dead = 1; /* it can be removed */ 1936 ++next; 1937 } 1938 else 1939 { 1940 if (found_dead) /* unlink garbage */ 1941 { 1942 if (last_live < GB && last_live->val.ptr < GB) { 1943 Trail_Pword(last_live) 1944 } 1945 if (next < GB) /* To reduce future trailing ... */ 1946 { 1947 pword *new = TG; /* use fresh copy of the list cell */ 1948 Push_List_Frame(); 1949 new[0] = next[0]; 1950 new[1] = next[1]; 1951 next = new; 1952 } 1953 Make_List(last_live, next); 1954 found_dead = 0; 1955 } 1956 last_live = ++next; /* proceed to next one */ 1957 } 1958#else 1959 ++next; 1960#endif 1961 1962 Dereference_(next); 1963 if (!IsList(next->tag)) 1964 break; 1965 next = next->val.ptr; 1966 } 1967 1968#ifdef SUSP_LIST_CLEANUP 1969 if (found_dead) /* unlink tail garbage */ 1970 { 1971 if (last_live < GB && last_live->val.ptr < GB) { 1972 Trail_Pword(last_live) 1973 } 1974 Make_Stamp(last_live); /* a timestamped [] */ 1975 } 1976#endif 1977 Succeed_ 1978} 1979 1980 1981/* 1982 * This is basically a subset of ec_schedule_susps: 1983 * It does not schedule, but only cleans up the list. 1984 */ 1985int 1986ec_prune_suspensions(pword *next) 1987{ 1988 pword *last_live, *p; 1989 int found_dead = 0; 1990 1991 last_live = next; 1992 Dereference_(next); 1993 if (IsList(next->tag)) { 1994 next = next->val.ptr; 1995 } else if (IsNil(next->tag) || IsRef(next->tag)) { 1996 Succeed_ 1997 } else { 1998 Bip_Error(TYPE_ERROR) 1999 } 2000 2001 for (;;) 2002 { 2003 p = next; /* get the suspension */ 2004 Dereference_(p); 2005 if (!IsTag(p->tag.kernel, TSUSP)) { 2006 Bip_Error(TYPE_ERROR) 2007 } 2008 p = p->val.ptr; 2009 2010 /* This is the important condition: */ 2011 if (SuspDead(p) || (!SuspDemon(p) && SuspScheduled(p))) 2012 { 2013 found_dead = 1; /* it can be removed */ 2014 ++next; 2015 } 2016 else 2017 { 2018 if (found_dead) /* unlink garbage */ 2019 { 2020 if (last_live < GB && last_live->val.ptr < GB) { 2021 Trail_Pword(last_live) 2022 } 2023 if (next < GB) /* To reduce future trailing ... */ 2024 { 2025 pword *new = TG; /* use fresh copy of the list cell */ 2026 Push_List_Frame(); 2027 new[0] = next[0]; 2028 new[1] = next[1]; 2029 next = new; 2030 } 2031 Make_List(last_live, next); 2032 found_dead = 0; 2033 } 2034 last_live = ++next; /* proceed to next one */ 2035 } 2036 2037 Dereference_(next); 2038 if (!IsList(next->tag)) 2039 break; 2040 next = next->val.ptr; 2041 } 2042 2043 if (found_dead) /* unlink tail garbage */ 2044 { 2045 if (last_live < GB && last_live->val.ptr < GB) { 2046 Trail_Pword(last_live) 2047 } 2048 Make_Stamp(last_live); /* a timestamped [] */ 2049 } 2050 Succeed_ 2051} 2052 2053 2054int 2055p_schedule_suspensions(value vpos, type tpos, value vattr, type tattr) 2056{ 2057 Check_Integer(tpos); 2058 Check_Structure(tattr); 2059 if (vpos.nint < 1 || vpos.nint > DidArity(vattr.ptr->val.did)) 2060 { 2061 Bip_Error(RANGE_ERROR); 2062 } 2063 return ec_schedule_susps(&vattr.ptr[vpos.nint]); 2064} 2065 2066 2067/* 2068 * set_suspension_priority(+Susp, +Prio) 2069 * 2070 * Change a suspension's priority. This only has an effect as long 2071 * as the suspension has not been scheduled for waking. 2072 */ 2073int 2074p_set_suspension_priority(value vsusp, type tsusp, value vprio, type tprio) 2075{ 2076 Check_Integer(tprio) 2077 Check_Type(tsusp, TSUSP) 2078 if (SuspDead(vsusp.ptr)) 2079 { 2080 Bip_Error(TYPE_ERROR); 2081 } 2082 if (SuspPrio(vsusp.ptr) != (unsigned) vprio.nint) 2083 { 2084 Set_Susp_Prio(vsusp.ptr, vprio.nint); 2085 } 2086 Succeed_; 2087} 2088 2089 2090static int 2091p_get_priority(value vp, type tp) 2092{ 2093 Check_Output_Integer(tp) 2094 Return_Unify_Integer(vp, tp, WP) 2095} 2096 2097static int 2098p_set_priority(value vp, type tp) 2099{ 2100 int prio; 2101 Check_Integer(tp) 2102 prio = vp.nint > SUSP_MAX_PRIO ? SUSP_MAX_PRIO : vp.nint; 2103 Set_WP(prio) 2104 Succeed_ 2105} 2106 2107static int 2108p_set_priority2(value vp, type tp, value vt, type tt) 2109{ 2110 int prio; 2111 Check_Integer(tp) 2112 Check_Integer(tt) 2113 prio = vp.nint > SUSP_MAX_PRIO ? SUSP_MAX_PRIO : vp.nint; 2114 if (vt.nint) { 2115 Set_WP(prio) 2116 } else 2117 WP = prio; 2118 Succeed_ 2119} 2120 2121static int 2122p_first_woken(value pv, type pt, value v, type t) 2123{ 2124 pword *p; 2125 2126 Check_Integer(pt); 2127 if (pv.nint < 1 || pv.nint > SUSP_MAX_PRIO) { 2128 Bip_Error(RANGE_ERROR) 2129 } 2130 p = first_woken((int) pv.nint); 2131 if (!p) { 2132 Fail_; 2133 } else { 2134 Return_Unify_Pw(p->val, p->tag, v, t) 2135 } 2136} 2137 2138/* 2139 * Similar to last_suspension/1 - returns a structure with the 2140 * current state of the waking scheduler 2141 */ 2142static int 2143p_last_scheduled(value vg, type tg) 2144{ 2145 register pword *p = TG; 2146 int i; 2147 2148 i = DidArity(WL->val.did); 2149 TG += i + 1; /* + functor */ 2150 Check_Gc 2151 p->val.did = WL->val.did; 2152 p->tag.all = TDICT; 2153 for (; i > 0; i--) { 2154 p[i].val.all = WL[i].val.all; 2155 p[i].tag.kernel = WL[i].tag.kernel; 2156 } 2157#if 0 2158 WLPrevious(p)->tag.all = TGCONST; 2159#else 2160 WLPrevious(p)->tag.all = TNIL; 2161#endif 2162 Return_Unify_Structure(vg, tg, p) 2163} 2164 2165/* 2166 * last_scheduled(+OldWL, -NewWoken) 2167 * Similar to new_delays/2 - returns a list of suspensions 2168 * that have been woken (scheduled) since the OldWL. 2169 */ 2170static int 2171p_new_scheduled(value vold, type told, value vl, type tl) 2172{ 2173 register pword *o; 2174 register pword *n; 2175 register pword *s; 2176 register pword *u; 2177 pword *old; 2178 pword *new; 2179 pword *list; 2180 pword *l; 2181 pword *save_l; 2182 pword *save_tg; 2183 int i; 2184 word max; 2185 2186 Check_Structure(told); 2187#if 0 2188 if (WLPrevious(WL)->val.ptr != WLPrevious(vold.ptr)->val.ptr) { 2189 Fail_; /* not the same nesting level */ 2190 } 2191#endif 2192 max = WLMaxPrio(WL); 2193 old = WLFirst(vold.ptr); 2194 new = WLFirst(WL); 2195 l = list = TG++; 2196 Check_Gc; 2197 for (i = 0; i < max; i++) { 2198 n = new++; 2199 o = old++; /* no references allowed */ 2200 if (IsList(n->tag) && (!IsList(o->tag) || 2201 n->val.ptr != o->val.ptr)) { 2202 while (IsList(o->tag)) { 2203 o = o->val.ptr; 2204 s = o; 2205 Dereference_(s); 2206 if (!SuspDead(s->val.ptr)) 2207 break; 2208 o++; 2209 Dereference_(o); 2210 } 2211 save_tg = TG; 2212 save_l = l; 2213 for (;;) { 2214 n = n->val.ptr; 2215 s = n++; 2216 Dereference_(s); 2217 Dereference_(n); 2218 if (IsSusp(s->tag)) { 2219 u = s->val.ptr; 2220 if (!SuspDead(u)) { 2221 l->val.ptr = TG; 2222 l->tag.all = TLIST; 2223 l = TG; 2224 TG += 2; 2225 Check_Gc; 2226 *l++ = *s; 2227 } 2228 } 2229 if (IsNil(n->tag)) { 2230 /* we are at the end of new and we didn't find old */ 2231 if (!IsNil(o->tag)) { 2232 /* an old one is missing from the new one; this means 2233 * that it was just woken and there is nothing new */ 2234 TG = save_tg; 2235 l = save_l; 2236 } 2237 break; 2238 } else if (n->val.ptr == o) { 2239 break; 2240 } 2241 } 2242 } 2243 } 2244 l->tag.all = TNIL; 2245 Return_Unify_Pw(vl, tl, list->val, list->tag) 2246} 2247 2248static int 2249p_meta_index(value vname, type tname, value vi, type ti) 2250{ 2251 if (IsInteger(ti)) 2252 { 2253 dident name = meta_name(vi.nint); 2254 if (name == D_UNKNOWN) { Fail_; } 2255 Return_Unify_Atom(vname, tname, name); 2256 } 2257 if (IsAtom(tname)) 2258 { 2259 int i = meta_index(vname.did); 2260 if (i == 0) { Fail_; } 2261 Return_Unify_Integer(vi, ti, i); 2262 } 2263 Bip_Error(TYPE_ERROR); 2264} 2265 2266 2267static int 2268p_notify_constrained(value v, type t) 2269{ 2270 if (!IsMeta(t)) { 2271 Succeed_ 2272 } 2273 return notify_constrained(v.ptr); 2274} 2275 2276