1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) Honeywell Bull Inc., 1987                *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   6         *                                                         *
   7         * Copyright (c) 1972 by Massachusetts Institute of        *
   8         * Technology and Honeywell Information Systems, Inc.      *
   9         *                                                         *
  10         *********************************************************** */
  11 
  12 
  13 
  14 /****^  HISTORY COMMENTS:
  15   1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
  16      audit(86-05-13,Martinson), install(86-05-14,MR12.0-1056):
  17      Correct error message documentation.
  18   2) change(87-03-31,Fawcett), approve(87-04-23,MCR7672),
  19      audit(87-04-23,Farley), install(87-04-28,MR12.1-1028):
  20      Corrected dir_unlock_given_uid to use "ind".  Put the mylock check in
  21      LOCK_FAST into the stac do loop to possibly avoid a missed cache write
  22      notify on lock.pid.  Added VALIDATE_CACHE  internal proc to insure that
  23      the  cache and memory contents of lock_count and highset_in_use are the
  24      same and detect any differences.
  25                                                    END HISTORY COMMENTS */
  26 
  27 
  28 /* format: style3 */
  29 
  30 lock:
  31      procedure;
  32 
  33 /* format: off */
  34 
  35 /* *      LOCK - ring zero primitive for shared data base locking.
  36    *
  37    *      This procedure supplies a number of entry points for manipulating
  38    *      locks.  Its coding is dependent on the read-alter-rewrite ability
  39    *      provided by the STAC and STACQ instructions.
  40    *
  41    *      The following entry points are available for setting a lock:
  42    *
  43    *        lock$try -
  44    *
  45    *          declare lock$try external entry (ptr, fixed bin(35), fixed bin(35), fixed bin(1));
  46    *          call lock$try (lock_ptr, event, code, failsw);
  47    *
  48    *        lock$wait -
  49    *
  50    *          declare lock$wait external entry (ptr, fixed bin(35), fixed bin(35));
  51    *          call lock$wait (lock_ptr, event, code);
  52    *
  53    *        lock$dir_wait -
  54    *
  55    *          declare lock$dir_wait external entry (ptr, bit(36) aligned, fixed bin(35));
  56    *          call lock$dir_wait (dp, typelock,  code);
  57    *
  58    *        lock$dir_try -
  59    *
  60    *          declare lock$dir_try external entry (ptr, bit(36) aligned, fixed bin(35), fixed bin(1));
  61    *          call lock$dir_try (dp, typelock, code, failsw);
  62    *
  63    *      Where -
  64    *        lock_ptr               is a pointer to the lock to be set. (Input)
  65    *        dp           is a pointer to the directory whose lock is to be set. (Input)
  66    *        typelock     = "0"b if locked for read, = "1"b if locked for write. (Input)
  67    *        code         is a standard error code. (Output)
  68    *        event        is the event to be waited for if the lock cannot be set. (Input)
  69    *        failsw       = 0 if lock was set, = 1 if unable to set lock. (Output)
  70    *
  71    *        lock$dir_lock_(read write) -
  72    *           declare lock$dir_lock_(write read) entry (ptr, fixed bin (35));
  73    *           call lock$dir_lock_(write read) (dp, code);
  74    *
  75    *          These entries crash on mylock, and trust dir.uid, and salvage
  76    *          the directory under certain circumstances. They do wait for the lock.
  77    *
  78    *           lock$dir_lock_salvage -
  79    *
  80    *             declare lock$dir_lock_salvage entry (ptr, bit (36) aligned,
  81    *                 fixed bin (35));
  82    *             call lock$dir_lock_salvage (dp, uid, code);
  83    *
  84    *           This SIDE-DOOR for the salvager :
  85    *           1) derives the UID for locking from the kst, not dir.uid.
  86    *           2) returns mylock rather than crashing
  87    *           3) takes a write lock.
  88    *           4) returns the UID used for locking
  89    *
  90    *
  91    *      The following entry points are available for unlocking a lock:
  92    *
  93    *        lock$dir_unlock_given_uid -
  94    *
  95    *          declare lock$dir_unlock_given_uid
  96    *                external entry (bit (36) aligned);
  97    *          call lock$dir_unlock_given_uid (dir_uid);
  98    *
  99    *        This entrypoint is for use when the contents of the directory
 100    *         are untrustworthy.  Primarily for the salvager.
 101    *
 102    *        lock$dir_unlock -
 103    *
 104    *        declare lock$dir_unlock entry (pointer);
 105    *         call lock$dir_unlock (dp);
 106    *
 107    *        This is the ordinary dir-unlocker.
 108 
 109    *
 110    *        lock$unlock -
 111    *
 112    *          declare lock$unlock external entry (ptr, fixed bin(35));
 113    *          call lock$unlock (lock_ptr, event);
 114    *
 115    *      Where -
 116    *        lock_ptr               is a pointer to the lock to be unlocked. (Input)
 117    *        dp           is a pointer to the directory to be unlocked. (Input)
 118    *        event        is the event to be signalled after resetting the lock. (Input)
 119    *
 120    *
 121    *      Modifications:
 122    *      20 Apr 1975, Andre Bensoussan: Rewritten for the new storage system.
 123    *      23 Sep 1975, Andre Bensoussan: Move call to caller() from internal proc to beginning of each entry point.
 124    *      24 Sep 1975, Andre Bensoussan: dir.modify is no longer reset to 0 by unlock_dir.
 125    *         Also the entry lock$modify_dir has been eliminated.
 126    *         Added new entries for lock_ast and unlock_ast.
 127    *      25 Feb 1976, RE Mullen: Added ast lock metering code.
 128    *      13 Jul 1978, B. Greenberg: Changed not to DIRW per-process dirs, and clock and stacq bifs.
 129    *      13 Feb 1980, M. Grady: fixed race condition with lock_dir and on_line_salvager.
 130    *      10 Aug 1981, W. Olin Sibert: changed lock_dir to validate UID in dir header vs. UID in KSTE,
 131    *         changes for external static SST, and, *sigh*, format_pl1'd it.
 132    *      21 Nov 1981, J. Bongiovanni for ast lock metering
 133           Dec 81/Jan 82, Benson I. Margulies, multiple reader dir locks.
 134    *      2/82 BIM for salvager dir sidedoors.
 135    *      7 August 1982, J. Bongiovanni, don't stash AST locks in pds$lock_array,
 136    *               meter AST locking conditionally
 137    *      Modified 830111 BIM to improve interactions of locking and salvaging.
 138    *      13 January 1983, J. Bongiovanni, to fix some races and add a trap
 139    *      Modified 830118 BIM to try again to find the race.
 140    *      Modified 830817 BIM to use salvage_entry not salvage_sw.
 141    *      Modified 831107 BIM to make array of dir locks quick to reference.
 142    *      Modified 831110 BIM to revert to heap strategy for dir locks.
 143    *      Modified 841102 KPL to fix dirw and to improve its efficiency.
 144    */
 145 
 146 
 147 /* format: on */
 148 
 149 dcl       prds$processor_tag  ext fixed bin (3);
 150 dcl       absadr              entry (ptr, fixed bin (35)) returns (fixed bin (26));
 151 dcl       CPU_NAMES           char (8) aligned internal static options (constant) init ("abcdefgh");
 152 dcl       a_lock_ptr          pointer parameter;            /* Arguments - pointer to lock */
 153 dcl       a_dp                pointer parameter;            /* pointer to directory */
 154 dcl       a_ind               bit (36) aligned parameter;   /* wait event for lock */
 155 dcl       a_typelock          bit (36) aligned parameter;   /* = "0"b if read lock, = "1"b if write lock */
 156 dcl       a_code              fixed bin (35) parameter;     /* standard error code */
 157 dcl       a_failsw            fixed bin (1) parameter;      /* = 1 if try lock failed */
 158 dcl       a_dir_uid           bit (36) aligned;             /* returned to salvager */
 159 
 160 dcl       per_process_flag    bit (1);
 161 dcl       must_salvage        bit (1) aligned;
 162 dcl       ind                 bit (36) aligned;             /* wait event for lock */
 163 dcl       caller_ptr          pointer;                      /* pointer to where we were called from (+1) */
 164 dcl       dir_uid             bit (36) aligned;             /* global var set by LOCK_DIR_SALVAGE */
 165 dcl       code                fixed bin (35);               /* code set by internal procedure LOCK */
 166 dcl       failsw              fixed bin (1);
 167 dcl       (time_in, time_out) fixed bin (52);               /* temporaries for ast lock metering */
 168 
 169 dcl       seg_fault_error     condition;
 170 
 171 dcl       error_table_$mylock fixed bin (35) external static;
 172 dcl       error_table_$dir_damage
 173                               fixed bin (35) external static;
 174 dcl       error_table_$notadir
 175                               fixed bin (35) ext static;
 176 
 177 dcl       sst$ast_locked_at_time
 178                               fixed bin (71) external static;
 179 dcl       sst$ast_locked_total_time
 180                               fixed bin (71) external static;
 181 dcl       sst$ast_locking_count
 182                               fixed bin (35) external static;
 183 dcl       sst$ast_lock_wait_time
 184                               fixed bin (71) external static;
 185 dcl       sst$astl            bit (36) aligned external static;
 186 dcl       sst$dirlock_writebehind
 187                               fixed bin external static;
 188 dcl       sst$lock_waits      fixed bin (35) external static;
 189 dcl       sst$meter_ast_locking
 190                               fixed bin external static;
 191 dcl       tc_data$lock_error_severity
 192                               fixed bin external static;
 193 
 194 dcl       pds$block_lock_count
 195                               fixed bin external static;    /* count of locks set to this process */
 196 dcl       pds$processid       bit (36) aligned external static;
 197 dcl       tc_data$system_shutdown
 198                               fixed bin external static;    /* for determining whether to force the lock */
 199 
 200 dcl       caller              entry returns (pointer);      /* returns a pointer to our caller */
 201 dcl       get_kstep           entry (fixed bin, pointer, fixed bin (35));
 202 dcl       meter_ast_lock$lock entry;
 203 dcl       meter_ast_lock$unlock
 204                               entry;
 205 dcl       on_line_salvager    entry (pointer, fixed bin (35));
 206 dcl       pxss$addevent       entry (bit (36) aligned);
 207 dcl       pxss$delevent       entry (bit (36) aligned);
 208 dcl       pxss$notify         entry (bit (36) aligned);
 209 dcl       pxss$wait           entry;
 210 dcl       syserr              entry options (variable);
 211 dcl       update_vtoce        entry (pointer);
 212 
 213 dcl       (addr, baseno, binary, clock, hbound, max, null, segno, stac, stacq, substr, unspec)
 214                               builtin;
 215 
 216 
 217 try:
 218      entry (a_lock_ptr, a_ind, a_code, a_failsw);
 219 
 220           caller_ptr = caller ();
 221           call LOCK (a_lock_ptr, a_ind, a_code, a_failsw, 0 /* waitsw */);
 222           return;
 223 
 224 wait:
 225      entry (a_lock_ptr, a_ind, a_code);
 226 
 227           caller_ptr = caller ();
 228           call LOCK (a_lock_ptr, a_ind, a_code, failsw, 1 /* waitsw */);
 229           return;
 230 
 231 unlock:
 232      entry (a_lock_ptr, a_ind);
 233 
 234           caller_ptr = caller ();
 235           call UNLOCK (a_lock_ptr, a_ind);
 236           return;
 237 
 238 
 239 
 240 
 241 lock_fast:
 242      entry (a_lock_ptr);
 243           caller_ptr = caller ();
 244           call LOCK_FAST (a_lock_ptr);
 245           return;
 246 
 247 unlock_fast:
 248      entry (a_lock_ptr);
 249           caller_ptr = caller ();
 250           call UNLOCK_FAST (a_lock_ptr);
 251           return;
 252 
 253 
 254 lock_ast:
 255      entry;
 256           caller_ptr = caller ();
 257           time_in = clock ();
 258           call LOCK_FAST (addr (sst$astl));
 259           if sst$meter_ast_locking ^= 0
 260           then call meter_ast_lock$lock;
 261           time_out = clock ();
 262           sst$ast_lock_wait_time = sst$ast_lock_wait_time + time_out - time_in;
 263           sst$ast_locked_at_time = time_out;
 264           sst$ast_locking_count = sst$ast_locking_count + 1;
 265           return;
 266 
 267 
 268 unlock_ast:
 269      entry;
 270           caller_ptr = caller ();
 271           sst$ast_locked_total_time = sst$ast_locked_total_time - sst$ast_locked_at_time + clock ();
 272           if sst$meter_ast_locking ^= 0
 273           then call meter_ast_lock$unlock;
 274           call UNLOCK_FAST (addr (sst$astl));
 275           return;
 276 
 277 %page;
 278 
 279 dir_wait:
 280      entry (a_dp, a_typelock, a_code);
 281 
 282           caller_ptr = caller ();
 283           call LOCK_DIR (a_dp, a_typelock, a_code, failsw, 1 /* waitsw */);
 284 
 285           return;
 286 
 287 dir_try:
 288      entry (a_dp, a_typelock, a_code, a_failsw);
 289 
 290           caller_ptr = caller ();
 291           call LOCK_DIR (a_dp, a_typelock, a_code, a_failsw, 0 /* waitsw */);
 292           return;
 293 
 294 dir_unlock:
 295      entry (a_dp);
 296 
 297           caller_ptr = caller ();
 298           ind = a_dp -> dir.uid;
 299           call UNLOCK_DIR (a_dp, ind);
 300           return;
 301 
 302 dir_unlock_given_uid:
 303      entry (a_dir_uid);
 304 
 305           caller_ptr = caller ();
 306           ind = a_dir_uid;
 307           call UNLOCK_DIR_NOCHECK (null, ind);
 308           return;
 309 
 310 
 311 dir_lock_read:
 312      entry (a_dp, a_code);
 313 
 314           caller_ptr = caller ();
 315           call LOCK_DIR (a_dp, (36)"0"b, a_code, failsw, 1 /* waitsw */);
 316           if a_code = error_table_$mylock
 317           then call syserr (CRASH, "lock: dir_lock_read mylock err. dp =^p", a_dp);
 318           return;
 319 
 320 dir_lock_write:
 321      entry (a_dp, a_code);
 322 
 323           caller_ptr = caller ();
 324           call LOCK_DIR (a_dp, (36)"1"b, a_code, failsw, 1 /* waitsw */);
 325           if a_code = error_table_$mylock
 326           then call syserr (CRASH, "lock: dir_lock_write mylock err. dp =^p", a_dp);
 327           return;
 328 
 329 dir_lock_salvage:
 330      entry (a_dp, a_dir_uid, a_code);
 331 
 332           caller_ptr = caller ();
 333           dir_uid = ""b;
 334           call LOCK_DIR_SALVAGE (a_dp, (36)"1"b, a_code, failsw, 1 /* waitsw */);
 335                                                             /* Always locks for write */
 336           a_dir_uid = dir_uid;
 337           return;
 338 
 339 %page;
 340 
 341 LOCK:
 342      procedure (lock_ptr, ind, code, failsw, waitsw);
 343 
 344 dcl       lock_ptr            ptr,
 345           ind                 bit (36) aligned,
 346           code                fixed bin (35),
 347           failsw              fixed bin (1),
 348           waitsw              fixed bin (1);
 349 
 350 dcl       lwd                 bit (36) aligned based (lock_ptr);
 351 
 352           code = 0;
 353           failsw = 0;
 354 
 355           if tc_data$system_shutdown ^= 0
 356           then return;
 357 
 358           if lwd = pds$processid
 359           then do;
 360                     code = error_table_$mylock;
 361                     goto POST;
 362                end;
 363 
 364           pds$block_lock_count = pds$block_lock_count + 1;
 365 
 366           do while (^stac (lock_ptr, pds$processid));
 367                if waitsw = 0
 368                then do;
 369                          failsw = 1;
 370                          pds$block_lock_count = pds$block_lock_count - 1;
 371                          goto POST;
 372                     end;
 373 
 374                call pxss$addevent (ind);
 375 
 376                if lwd = "0"b
 377                then call pxss$delevent (ind);
 378                else do;
 379                          call pxss$wait;
 380                          sst$lock_waits = sst$lock_waits + 1;
 381                     end;
 382           end;
 383 
 384 POST:
 385           return;
 386 
 387      end LOCK;
 388 
 389 %page;
 390 
 391 UNLOCK:
 392      procedure (lock_ptr, ind);
 393 
 394 dcl       lock_ptr            ptr,
 395           lwd                 bit (36) aligned based (lock_ptr),
 396           ind                 bit (36) aligned;
 397 
 398 
 399 
 400           code = 0;
 401           failsw = 0;
 402 
 403           if tc_data$system_shutdown ^= 0
 404           then return;                                      /* system shutdown ? */
 405 
 406 
 407           if pds$block_lock_count <= 0
 408           then do;
 409                     call syserr (tc_data$lock_error_severity, "lock: pds$block_lock_count <= 0. caller = ^p.", caller ());
 410                     pds$block_lock_count = 0;
 411                end;
 412 
 413           if ^stacq (lwd, "000000000000"b3, pds$processid)
 414           then do;
 415                     call syserr (tc_data$lock_error_severity, "lock: lock ^p not equal to processid. caller = ^p",
 416                          addr (lwd), caller ());
 417                     goto FORGET_RETURN;
 418                end;
 419 
 420           if lwd = pds$processid                            /* Always crash if the hardware craps */
 421           then call syserr (CRASH, "lock: stacq hardware failure on ^p", lock_ptr);
 422           call pxss$notify (ind);                           /* tell the world */
 423 
 424 FORGET_RETURN:
 425           pds$block_lock_count = pds$block_lock_count - 1;
 426 
 427           return;
 428 
 429      end UNLOCK;
 430 
 431 %page;
 432 
 433 LOCK_FAST:
 434      proc (lock_ptr);
 435 
 436 
 437 %include hc_lock;
 438 /* the ptr in here becomes a parameter */
 439 
 440           if tc_data$system_shutdown ^= 0
 441           then return;
 442 
 443           do while (^stac (addr (lock.pid), pds$processid));
 444                if lock.pid = pds$processid
 445                then call syserr (CRASH, "lock: lock_fast mylock err ^p", lock_ptr);
 446                lock.notify_sw = "1"b;
 447                call pxss$addevent (lock.event);
 448                if (lock.pid ^= "0"b & lock.notify_sw = "1"b)
 449                then call pxss$wait;
 450                else call pxss$delevent (lock.event);
 451           end;
 452 
 453           pds$block_lock_count = pds$block_lock_count + 1;
 454           return;
 455 
 456      end LOCK_FAST;
 457 
 458 %page;
 459 
 460 UNLOCK_FAST:
 461      proc (lock_ptr);
 462 
 463 %include hc_lock;
 464 /* the ptr in here becomes the parameter */
 465 
 466 
 467           if tc_data$system_shutdown ^= 0
 468           then return;
 469 
 470           if ^stacq (lock.pid, "000000000000"b3, pds$processid)
 471           then do;
 472                     call syserr (tc_data$lock_error_severity,
 473                          "lock: unlock_fast lock ^p not locked to process. caller = ^p.", lock_ptr, caller ());
 474                     return;
 475                end;
 476           if lock.pid = pds$processid
 477           then call syserr (CRASH, "lock: stacq hardware failure on ^p", lock_ptr);
 478 
 479           if lock.notify_sw
 480           then do;
 481                     lock.notify_sw = "0"b;
 482                     call pxss$notify (lock.event);
 483                end;
 484           pds$block_lock_count = pds$block_lock_count - 1;
 485           return;
 486 
 487      end UNLOCK_FAST;
 488 
 489 %page;
 490 
 491 LOCK_DIR:
 492      procedure (dirp, typelock, code, failsw, waitsw);
 493 
 494 dcl       dirp                ptr;
 495 dcl       typelock            bit (36) aligned;
 496 dcl       code                fixed bin (35);
 497 dcl       failsw              fixed bin (1);
 498 dcl       waitsw              fixed bin (1);
 499 
 500 dcl       get_kstep_code      fixed bin (35);
 501 dcl       salvage_entry       bit (1) aligned;
 502 dcl       severity            fixed bin;
 503 dcl       uid_to_lock         bit (36) aligned;
 504 dcl       dir_lockx           fixed bin;
 505 
 506           salvage_entry = "0"b;
 507           go to LOCK_START;
 508 
 509 LOCK_DIR_SALVAGE:
 510      entry (dirp, typelock, code, failsw, waitsw);
 511 
 512           salvage_entry = "1"b;
 513 
 514 LOCK_START:
 515           code = 0;
 516           failsw = 0;
 517 
 518           if tc_data$system_shutdown ^= 0
 519           then return;
 520 
 521           dir_lock_segp = addr (dir_lock_seg$);
 522           dir_lock_all_locksp = dir_lock_seg.header.locks_ptr;
 523           dir_lock_all_readersp = dir_lock_seg.header.readers_ptr;
 524 
 525           call get_kstep (segno (dirp), kstep, get_kstep_code);
 526                                                             /* The code is nonzero for fake dirs -- */
 527                                                             /* happens if dirp is a hardcore segment (stack_0) */
 528           if salvage_entry
 529           then do;
 530                     if get_kstep_code ^= 0                  /* needed for salvaging */
 531                     then do;
 532                               code = get_kstep_code;
 533                               return;
 534                          end;
 535                     if ^kste.dirsw
 536                     then do;                                /* Not a dir? */
 537                               code = error_table_$notadir;
 538                               return;
 539                          end;
 540                     dir_uid = kste.uid;
 541                end;
 542 
 543 RELOCK:
 544           if salvage_entry
 545           then uid_to_lock = dir_uid;                       /* The REAL uid, rather than what was recorded inside the dir */
 546           else uid_to_lock = dirp -> dir.uid;               /* let a seg_fault happen here */
 547 
 548 
 549 /****
 550 Here, we make sure that the UID in the directory matches the UID in the
 551 kste, which, perforce, must have been derived from the branch at some time in
 552 the past.  This check is skipped, however, if we find that the "directory" is
 553 actually in a non-directory segment, since the supervisor occasionally
 554 constructs imitation directory headers in automatic storage just so it can
 555 lock with the right UID.  If the UID's fail to match, then the dir is
 556 salvaged. If we are called from the salvager, though, we skip all this.
 557 *****/
 558 
 559           if ^salvage_entry
 560           then do;
 561                     must_salvage = "0"b;
 562                     if (dirp -> dir.uid = ""b)              /* Cannot be correct */
 563                     then must_salvage = "1"b;
 564                     else if (get_kstep_code = 0)
 565                     then /* means segno is valid, and hence kstep is valid */
 566                          if kste.dirsw
 567                          then /* only check directories */
 568                               if (dirp -> dir.uid ^= kste.uid)
 569                               then must_salvage = "1"b;
 570 
 571                     if must_salvage                         /* Flunked the test */
 572                     then do;                                /* Neither the dir not dir_lock_seg is locked
 573 here */
 574                               call LOCK_FOR_SALVAGE_AND_SALVAGE (dirp, code);
 575                                                             /* they will be locked and unlocked here. */
 576                               if code = 0 & dirp -> dir.uid ^= ""b
 577                               then go to RELOCK;            /* Dir is still valid */
 578                               code = error_table_$dir_damage;
 579                                                             /* dir went west */
 580                               return;
 581                          end;                               /** salvage case */
 582                end;
 583 
 584 /************************ LOCK DIR LOCK SEG *********************************/
 585 
 586 
 587           call LOCK_FAST (dir_lock_segp);
 588 
 589           dir_lockx = FIND_OR_MAKE_DIR_LOCK (uid_to_lock);
 590           dir_lockp = addr (dir_lock_all_dir_locks (dir_lockx));
 591 
 592           call VALIDATE_CACHE (addr (dir_lock.lock_count)); /* ensure cache is correct */
 593 
 594           if dir_lock.lock_count > 0
 595           then do;                                          /** Write Lock Locked */
 596                     if dir_lock.write_locker ^= pds$processid
 597                                                             /* Not Us */
 598                     then go to LOCK_NOT_AVAILABLE;          /* common to read vs. write and write vs. write. */
 599                     else go to MYLOCK_RETURN;
 600                end;
 601           else do;                                          /* Read or no lock */
 602                     dir_read_lockers_ptr = addr (dir_lock_all_readers (dir_lockx, 1));
 603                     if THIS_PROCESS_IS_A_READER (dir_lockp, dir_read_lockers_ptr)
 604                                                             /* some kind of mylock */
 605                     then do;                                /* we do not know a recovery mechanism for this one. */
 606                               if typelock ^= ""b            /* We want write */
 607                               then do;
 608                                         severity = tc_data$lock_error_severity;
 609                                         if severity ^= CRASH
 610                                         then severity = TERMINATE_PROCESS;
 611 
 612                                         call syserr (severity,
 613                                              "lock: LOCK_DIR: write lock call with read lock held. dp = ^p, uid = ^w.",
 614                                              dirp, uid_to_lock);
 615                                    end;                     /* Control never passes here */
 616                               else go to MYLOCK_RETURN;     /* simple read mylock */
 617                          end;
 618 
 619                     if /* tree */ typelock ^= ""b           /* want write ? */
 620                     then if dir_lock.lock_count ^= 0        /* locked for read */
 621                          then goto LOCK_NOT_AVAILABLE;      /* wait for it */
 622                          else call LOCK_FOR_WRITE (dir_lockp);
 623                     else call ADD_THIS_PROCESS_AS_READER (dir_lockp, dir_read_lockers_ptr);
 624                                                             /* no, want read */
 625                end;
 626 
 627 /******* UNLOCK DIR LOCK SEG *********************************************/
 628 
 629 
 630 
 631 UNLOCK_DIR_LOCK_SEG_RETURN:
 632           call UNLOCK_FAST (dir_lock_segp);
 633 
 634           if ^salvage_entry
 635           then if dirp -> dir.modify
 636                then if code = 0
 637                     then do;
 638                               call dir_unlock (dirp);
 639                               call LOCK_FOR_SALVAGE_AND_SALVAGE (dirp, code);
 640                               if code = 0
 641                               then go to RELOCK;
 642                          end;
 643           return;
 644 
 645 /****** The following paths return to UNLOCK_DIR_LOCK_SEG_RETURN *****/
 646 
 647 
 648 MYLOCK_RETURN:
 649           code = error_table_$mylock;
 650           go to UNLOCK_DIR_LOCK_SEG_RETURN;
 651 
 652 
 653 LOCK_NOT_AVAILABLE:
 654           if waitsw = 0
 655           then do;
 656                     failsw = 1;
 657                     go to UNLOCK_DIR_LOCK_SEG_RETURN;
 658                end;
 659 
 660 /********** Waiting is required, wait. */
 661 
 662           call pxss$addevent (uid_to_lock);
 663           dir_lock.notify_sw = "1"b;
 664           call UNLOCK_FAST (dir_lock_segp);
 665           call pxss$wait;                                   /* since we set notify under the lock, there is no race. */
 666           sst$lock_waits = sst$lock_waits + 1;
 667           goto LOCK_START;                                  /* Anything can happen, so revalidate */
 668 ^L
 669 
 670 THIS_PROCESS_IS_A_READER:
 671      procedure (a_dir_lockp, a_dir_readersp) returns (bit (1) aligned);
 672 
 673 declare   a_dir_lockp         pointer;
 674 declare   a_dir_readersp      pointer;
 675 declare   l_dir_readersp      pointer;
 676 declare   l_dir_readers       (dir_lock_seg.header.max_readers) bit (36) aligned based (l_dir_readersp);
 677 declare   rx                  fixed bin;                    /* ReaderIndex */
 678 
 679 
 680           if a_dir_lockp -> dir_lock.lock_count = 0
 681           then return ("0"b);
 682           l_dir_readersp = a_dir_readersp;
 683           do rx = 1 to dir_lock_seg.header.max_readers;
 684                if l_dir_readers (rx) = pds$processid
 685                then return ("1"b);
 686           end;
 687           return ("0"b);
 688      end THIS_PROCESS_IS_A_READER;
 689 ^L
 690 
 691 FIND_OR_MAKE_DIR_LOCK:
 692      procedure (a_UID) returns (fixed bin);
 693 
 694 declare   a_UID               bit (36) aligned;
 695 declare   UID                 bit (36) aligned;
 696 declare   dx                  fixed bin;
 697 declare   first_free_dx       fixed bin;
 698 declare   l_dir_lockp         pointer;
 699 declare   1 l_dir_lock        aligned like dir_lock based (l_dir_lockp);
 700 declare   l_dir_readersp      pointer;
 701 declare   find_only           bit (1) aligned;
 702 
 703           find_only = "0"b;
 704           go to Join;
 705 
 706 FIND_DIR_LOCK:
 707      entry (a_UID) returns (fixed bin);
 708 
 709           find_only = "1"b;
 710 
 711 Join:
 712           UID = a_UID;
 713           first_free_dx = 0;
 714           dir_lock_seg.header.meters.find_calls = dir_lock_seg.header.find_calls + 1;
 715 
 716           call VALIDATE_CACHE (addr (dir_lock_seg.header.highest_in_use));
 717                                                             /* ensure cache is correct */
 718           do dx = 1 to dir_lock_seg.header.highest_in_use;
 719                if dir_lock_all_dir_locks (dx).uid = UID
 720                then go to FOUND_ENTRY;
 721                else if dir_lock_all_dir_locks (dx).uid = (36)"0"b & first_free_dx = 0
 722                then first_free_dx = dx;
 723           end;
 724 
 725           dir_lock_seg.header.meters.find_failures = dir_lock_seg.header.meters.find_failures + 1;
 726           if find_only
 727           then return (-1);
 728 
 729 
 730           if first_free_dx = 0
 731           then do;
 732                     if dir_lock_seg.header.highest_in_use = dir_lock_seg.header.n_dir_locks
 733                     then call syserr (CRASH, "lock: LOCK_DIR: dir_lock_seg full.");
 734                     dir_lock_seg.header.highest_in_use, first_free_dx = dir_lock_seg.header.highest_in_use + 1;
 735                     dir_lock_seg.header.meters.max_in_use = max (dir_lock_seg.header.meters.max_in_use, first_free_dx);
 736                end;
 737 
 738           l_dir_lockp = addr (dir_lock_all_dir_locks (first_free_dx));
 739           unspec (l_dir_lock) = ""b;
 740           l_dir_readersp = addr (dir_lock_seg.readers (first_free_dx, 1));
 741           l_dir_readersp -> dir_read_lockers (*) = ""b;
 742 
 743           l_dir_lock.uid = a_UID;
 744           return (first_free_dx);
 745 
 746 FOUND_ENTRY:
 747           l_dir_lockp = addr (dir_lock_all_dir_locks (dx));
 748           return (dx);
 749      end FIND_OR_MAKE_DIR_LOCK;
 750 
 751 LOCK_FOR_WRITE:
 752      procedure (a_dir_lockp);
 753 
 754 declare   a_dir_lockp         pointer;
 755 declare   l_dir_lockp         pointer;
 756 declare   1 l_dir_lock        aligned like dir_lock based (l_dir_lockp);
 757 declare   rx                  fixed bin;
 758 
 759           l_dir_lockp = a_dir_lockp;
 760           l_dir_lock.write_locker = pds$processid;
 761           l_dir_lock.lock_count = 1;
 762           l_dir_lock.notify_sw = "0"b;
 763           l_dir_lock.salvage_sw = salvage_entry;            /* GLOBAL */
 764           pds$block_lock_count = pds$block_lock_count + 1;
 765           return;
 766 
 767 ADD_THIS_PROCESS_AS_READER:
 768      entry (a_dir_lockp, a_dir_readersp);
 769 
 770 declare   a_dir_readersp      pointer;
 771 declare   l_dir_readersp      pointer;
 772 declare   l_dir_readers       (dir_lock_seg.header.max_readers) bit (36) aligned based (l_dir_readersp);
 773 
 774           l_dir_lockp = a_dir_lockp;
 775           l_dir_readersp = a_dir_readersp;
 776           do rx = 1 to hbound (l_dir_readers, 1) while (l_dir_readers (rx) ^= ""b);
 777           end;
 778           if rx > hbound (l_dir_readers, 1)
 779           then call syserr (CRASH, "lock: LOCK_DIR: Too many readers.");
 780 
 781           call VALIDATE_CACHE (addr (l_dir_lock.lock_count));
 782                                                             /* ensure cache is correct */
 783           l_dir_lock.lock_count = l_dir_lock.lock_count - 1;
 784           l_dir_readers (rx) = pds$processid;
 785           pds$block_lock_count = pds$block_lock_count + 1;
 786           return;
 787 
 788 UNLOCK_THIS_DIR:
 789      entry (a_dir_lockx, a_uid);                            /* Checks for screwups */
 790 
 791 declare   a_dir_lockx         fixed bin;
 792 declare   a_uid               bit (36) aligned;
 793 
 794           l_dir_lockp = addr (dir_lock_all_dir_locks (a_dir_lockx));
 795           l_dir_readersp = addr (dir_lock_all_readers (a_dir_lockx, 1));
 796           if l_dir_lock.uid ^= a_uid
 797           then do;
 798                     call syserr (tc_data$lock_error_severity, "lock: UNLOCK_DIR: UID Mismatch.");
 799                     return;
 800                end;
 801 
 802           call VALIDATE_CACHE (addr (l_dir_lock.lock_count));
 803                                                             /* ensure cache is correct */
 804           if l_dir_lock.lock_count = 0
 805           then do;
 806                     call syserr (tc_data$lock_error_severity, "lock: UNLOCK_DIR: lock count 0.");
 807                     return;
 808                end;
 809           else if l_dir_lock.lock_count < 0
 810           then do;
 811                     do rx = 1 to hbound (l_dir_readers, 1) while (l_dir_readers (rx) ^= pds$processid);
 812                     end;
 813                     if rx > hbound (l_dir_readers, 1)
 814                     then do;
 815                               call syserr (tc_data$lock_error_severity,
 816                                    "lock: UNLOCK_DIR: lock not read locked to process.");
 817                               return;
 818                          end;
 819                     l_dir_lock.lock_count = l_dir_lock.lock_count + 1;
 820                     l_dir_readers (rx) = ""b;
 821                     if l_dir_lock.notify_sw
 822                     then if l_dir_lock.lock_count = 0
 823                          then do;
 824                                    l_dir_lock.notify_sw = "0"b;
 825                                    call pxss$notify (l_dir_lock.uid);
 826                               end;
 827                end;
 828           else if l_dir_lock.lock_count > 0
 829           then do;
 830                     if l_dir_lock.write_locker ^= pds$processid
 831                     then do;
 832                               call syserr (tc_data$lock_error_severity,
 833                                    "lock: UNLOCK_DIR: lock not write locked to process.");
 834                               return;
 835                          end;
 836                     l_dir_lock.lock_count = 0;
 837                     l_dir_lock.write_locker = ""b;
 838                     if l_dir_lock.notify_sw
 839                     then do;
 840                               l_dir_lock.notify_sw = "0"b;
 841                               call pxss$notify (l_dir_lock.uid);
 842                          end;
 843                end;
 844           pds$block_lock_count = pds$block_lock_count - 1;
 845           if (l_dir_lock.lock_count = 0) & (l_dir_lock.uid ^= (36)"1"b)
 846                                                             /* leave the root at a nice low slot */
 847           then do;
 848                     unspec (l_dir_lock) = ""b;
 849 
 850                     call VALIDATE_CACHE (addr (dir_lock_seg.header.highest_in_use));
 851                                                             /* ensure cache is correct */
 852                     if a_dir_lockx = dir_lock_seg.header.highest_in_use
 853                     then dir_lock_seg.header.highest_in_use = max (0, dir_lock_seg.header.highest_in_use - 1);
 854                                                             /* last one out please close the light */
 855                end;
 856 
 857           return;
 858      end LOCK_FOR_WRITE;
 859 
 860 LOCK_FOR_SALVAGE_AND_SALVAGE:
 861      procedure (dir_ptr, code);
 862 declare   dir_ptr             pointer;
 863 declare   correct_uid         bit (36) aligned;
 864 declare   code                fixed bin (35);
 865 
 866           code = 0;
 867           call dir_lock_salvage (dir_ptr, correct_uid, code);
 868           if code ^= 0
 869           then return;
 870 
 871           call on_line_salvager (dir_ptr, code);
 872           call dir_unlock_given_uid (correct_uid);
 873 
 874           return;
 875      end LOCK_FOR_SALVAGE_AND_SALVAGE;
 876 
 877 %page;
 878 
 879 UNLOCK_DIR:
 880      entry (dirp, a_uid);
 881 
 882 dcl       a_uid               bit (36) aligned;
 883 
 884 dcl       uid_to_unlock       bit (36) aligned;
 885 dcl       nocheck_entry       bit (1);
 886 
 887 dcl       get_ptrs_$given_segno
 888                               entry (fixed bin) returns (ptr);
 889 dcl       pc_wired$write_wait_uid
 890                               entry (ptr, fixed bin, fixed bin, bit (36) aligned);
 891 
 892 
 893           nocheck_entry = "0"b;
 894           go to UNLOCK_START;
 895 
 896 UNLOCK_DIR_NOCHECK:
 897      entry (dirp, a_uid);
 898 
 899           nocheck_entry = "1"b;
 900 
 901 UNLOCK_START:
 902           uid_to_unlock = a_uid;
 903           if tc_data$system_shutdown ^= 0
 904           then return;
 905 
 906           dir_lock_segp = addr (dir_lock_seg$);
 907           dir_lock_all_locksp = dir_lock_seg.header.locks_ptr;
 908           dir_lock_all_readersp = dir_lock_seg.header.readers_ptr;
 909 
 910           per_process_flag = "0"b;
 911 
 912           if dirp ^= null & ^nocheck_entry
 913           then begin;
 914 
 915                     on seg_fault_error go to DIR_GONE;
 916 
 917                     if dirp -> dir.modify
 918                     then call syserr (JUST_LOG, "lock: unlock_dir with dir.modify - uid = ^w - callerp = ^p", ind,
 919                               caller ());
 920                     per_process_flag = dirp -> dir.per_process_sw;
 921                                                             /* Save for unlocking */
 922                end;
 923 
 924 DIR_GONE:
 925           call LOCK_FAST (dir_lock_segp);
 926 
 927           dir_lockx = FIND_DIR_LOCK (uid_to_unlock);
 928 
 929           if dir_lockx = -1
 930           then call TRY_TO_FIND_A_BETTER_UID;               /* This can change dir_lockx */
 931                                                             /* and uid_to_unlock */
 932           if dir_lockx = -1
 933           then do;
 934                     call syserr (tc_data$lock_error_severity, "lock: UNLOCK_DIR: dir ^w not locked. caller = ^p.", ind,
 935                          caller ());
 936                     go to UNLOCK_SIDE_RETURN;
 937                end;
 938 
 939           call PERHAPS_WRITE_BEHIND (dir_lockx);
 940 
 941           call UNLOCK_THIS_DIR (dir_lockx, uid_to_unlock);
 942 
 943 UNLOCK_SIDE_RETURN:
 944           call UNLOCK_FAST (dir_lock_segp);
 945           return;
 946 ^L
 947 
 948 
 949 
 950 TRY_TO_FIND_A_BETTER_UID:
 951      procedure;
 952 
 953           if dirp = null ()
 954           then return;
 955 
 956           call get_kstep (binary (baseno (dirp)), kstep, get_kstep_code);
 957           if ^(get_kstep_code = 0 & kste.dirsw & kste.uid ^= uid_to_unlock)
 958           then return;
 959 
 960           uid_to_unlock = kste.uid;
 961           dir_lockx = FIND_DIR_LOCK (uid_to_unlock);
 962 
 963           call VALIDATE_CACHE (addr (dir_lock_all_dir_locks (dir_lockx).lock_count));
 964                                                             /* ensure cache is correct */
 965           if dir_lock_all_dir_locks (dir_lockx).lock_count = 0
 966           then do;
 967                     dir_lockx = -1;
 968                     return;
 969                end;
 970 
 971           call syserr (JUST_LOG, "lock: UNLOCK_DIR: dir ^w unlock called with bad uid, caller = ^p", ind, caller ());
 972      end TRY_TO_FIND_A_BETTER_UID;
 973 ^L
 974 
 975 PERHAPS_WRITE_BEHIND:
 976      procedure (dirx);
 977 
 978 declare   dirx                fixed bin;
 979 
 980           if dirp = null ()
 981           then return;
 982 
 983           if sst$astl = pds$processid
 984           then call syserr (CRASH, "lock: AST lock set at dir unlock time.");
 985 
 986           if sst$dirlock_writebehind = 0 | per_process_flag
 987           then return;
 988 
 989           call VALIDATE_CACHE (addr (dir_lock_all_dir_locks (dirx).lock_count));
 990                                                             /* ensure cache is correct */
 991           if dir_lock_all_dir_locks (dirx).lock_count < 0
 992           then return;
 993 
 994           astep = get_ptrs_$given_segno (segno (dirp));
 995           if astep ^= null
 996           then do;                                          /* Writebehind time. */
 997                     call UNLOCK_FAST (dir_lock_segp);       /* force write not under dir_lock_seg lock */
 998 
 999                     call pc_wired$write_wait_uid (astep, 0, -1, uid_to_unlock);
1000                     if aste.fmchanged
1001                     then do;                                /* Cant be OFF fraudulently */
1002                               call lock_ast;
1003                               if aste.uid = uid_to_unlock
1004                               then call update_vtoce (astep);
1005                               call unlock_ast;
1006                          end;
1007 
1008                     call LOCK_FAST (dir_lock_segp);         /* UNLOCK_THIS_DIR will make sure that dir_lockx still describes uid_to_unlock */
1009                end;
1010 
1011      end PERHAPS_WRITE_BEHIND;
1012      end LOCK_DIR;
1013 
1014 VALIDATE_CACHE:
1015      proc (word_ptr);
1016 dcl       word                based (word_ptr) bit (36) aligned;
1017 dcl       word_ptr            ptr;
1018 
1019           if ^stacq (word, word, word)                      /* ensure cache is correct */
1020           then call syserr (ANNOUNCE, "lock: VALIDATE_CACHE: FAILED running on cpu ^a, memory address ^8o (oct)",
1021                     substr (CPU_NAMES, (prds$processor_tag + 1), 1), absadr (word_ptr, (0)));
1022 
1023      end VALIDATE_CACHE;
1024 
1025 /* format: off */
1026 %page; %include hc_lock;
1027 %page; %include dir_lock_seg_;
1028 %page; %include aste;
1029 %page; %include kst;
1030 %page; %include dir_header;
1031 %page; %include syserr_constants;
1032 %page;
1033 
1034 /* BEGIN MESSAGE DOCUMENTATION
1035 
1036    Message:
1037    lock: dir_lock_read mylock err. dp =PTR
1038 
1039    S: $crash
1040 
1041    T: $run
1042 
1043    M: An attempt to lock a directory for reading found the directory
1044    already locked to this process.  This indicates a supervisor
1045    programming error.
1046 
1047    A: $reboot
1048 
1049    Message:
1050    lock: dir_lock_write mylock err. dp =PTR
1051 
1052    S: $crash
1053 
1054    T: $run
1055 
1056    M: An attempt to lock a directory for writing found the directory
1057    already locked to this process.  This indicates a supervisor
1058    programming error.
1059 
1060    A: $reboot
1061 
1062    Message:
1063    lock: pds$block_lock_count <= 0. caller = PTR
1064 
1065    S: $lock_severity
1066 
1067    T: $run
1068 
1069    M: An attempt to unlock a lock found that the process was holding no
1070    locks.  This indicates a supervisor programming error.
1071 
1072    A: $reboot
1073 
1074    Message:
1075    lock: lock PTR not equal to processid. caller = PTR
1076 
1077    S: $lock_severity
1078 
1079    T: $run
1080 
1081    M: An attempt was made to unlock a lock found not to be held by this
1082    process.  This indicates a supervisor programming error.
1083 
1084    A: $reboot
1085 
1086    Message:
1087    lock: stacq hardware failure on PTR
1088 
1089    S: $crash
1090 
1091    T: $run
1092 
1093    M: The hardware failed to unlock the specified lock using a stacq
1094    instruction.
1095 
1096    A: Fix the hardware.
1097 
1098    Message:
1099    lock: lock_fast mylock err PTR
1100 
1101    S: $crash
1102 
1103    T: $run
1104 
1105    M: An attempt to lock a fast lock found the lock already locked to
1106    the requesting process.  This indicates a supervisor programming
1107    error.
1108 
1109    A: $reboot
1110 
1111    Message:
1112    lock: unlock_fast lock PTR not locked to process. caller = PTR
1113 
1114    S: $lock_severity
1115 
1116    T: $run
1117 
1118    M: An attempt to unlock a fast lock found that the lock was not held
1119    by the requesting process.  This indicates a supervisor
1120    programming error.
1121 
1122    A: $reboot
1123 
1124    Message:
1125    lock: LOCK_DIR: write lock call with read lock held. dp = PTR, uid = UID.
1126 
1127    S: $term
1128 
1129    T: $run
1130 
1131    M: A request was made to lock a directory for writing when the process
1132    already possessed a read lock on that directory.  This indicates a
1133    supervisor programming error.
1134 
1135    A: $reboot
1136 
1137    Message:
1138    lock: LOCK_DIR: dir_lock_seg full.
1139 
1140    S: $crash
1141 
1142    T: $run
1143 
1144    M: The segment used to record all locked directories overflowed.
1145    This may be a hardware problem.
1146 
1147    A: $reboot
1148 
1149    Message:
1150    lock: LOCK_DIR: Too many readers.
1151 
1152    S: $crash
1153 
1154    T: $run
1155 
1156    M: Too many processes attempted to request a read lock on a given
1157    directory.  This may indicate a hardware problem.
1158 
1159    A: $reboot
1160 
1161    Message:
1162    lock: UNLOCK_DIR: UID Mismatch.
1163 
1164    S: $lock_severity
1165 
1166    T: $run
1167 
1168    M: When attempting to unlock a directory, the UID for the directory
1169    found in the dir_lock_seg entry did not match that of the directory.
1170 
1171    A: $reboot
1172 
1173    Message:
1174    lock: UNLOCK_DIR: lock count 0.
1175 
1176    S: $lock_severity
1177 
1178    T: $run
1179 
1180    M: An attempt to unlock a directory found the dir_lock_seg entry for
1181    the directory not listing the directory as locked.
1182 
1183    A: $reboot
1184 
1185    Message:
1186    lock: UNLOCK_DIR: lock not read locked to process.
1187 
1188    S: $lock_severity
1189 
1190    T: $run
1191 
1192    M: A request to unlock a directory locked for reading found that the
1193    requesting process was not holding the directory locked.
1194 
1195    A: $reboot
1196 
1197    Message:
1198    lock: UNLOCK_DIR: lock not write locked to process.
1199 
1200    S: $lock_severity
1201 
1202    T: $run
1203 
1204    M: A request to unlock a directory that was found to be locked for
1205    writing was not locked to this process.
1206 
1207    A: $reboot
1208 
1209    Message:
1210    lock: unlock_dir with dir.modify - uid = UID - callerp = PTR
1211 
1212    S: $log
1213 
1214    T: $run
1215 
1216    M: A directory being unlocked appears to have been undergoing
1217    a modification sequence that has not completed.
1218 
1219    A: The next reference to the directory will force a directory salvage.
1220 
1221    Message:
1222    lock: UNLOCK_DIR: dir DIR_LOCK_IND not locked. caller = PTR.
1223 
1224    S: $lock_severity
1225 
1226    T: $run
1227 
1228    M: A request to unlock a directory found that the dir_lock_seg entry
1229    does not show that the directory was locked.
1230 
1231 
1232   A: $reboot
1233 
1234    Message:
1235    lock: UNLOCK_DIR: dir DIR_LOCK_IND unlock called with bad uid, caller = PTR
1236 
1237    S: $log
1238 
1239    T: $run
1240 
1241    M: A request to unlock a directory found that the UID of the directory
1242    does not match the UID at the time the directory was locked.  However,
1243    the UID does match that in the KST.  This normally indicates that
1244    the directory was salvaged during the time that it was locked.
1245 
1246    Message:
1247    lock: AST lock set at dir unlock time.
1248 
1249    S: $crash
1250 
1251    T: $run
1252 
1253    M: The AST was found locked to this process at directory unlock time.
1254    This indicates a supervisor programming error.
1255 
1256    A: $reboot
1257 
1258    Message:
1259    lock: VALIDATE_CACHE: FAILED running on cpu N, memory address OOOOOOOO (oct).
1260 
1261    S: $info
1262 
1263    T: $run
1264 
1265    M:  This is most likely a cache write notify problem with the 8/70m
1266    processor "CPU N", or the System Control Unit containing the "memory
1267    address OOOOOOOO."
1268 
1269    A: $contact_sa
1270 
1271    END MESSAGE DOCUMENTATION */
1272 
1273      end lock;