1 /* ***********************************************************
   2    *                                                         *
   3    * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   4    *                                                         *
   5    *********************************************************** */
   6 
   7 
   8 /* format: style3 */
   9 /* Procedure to manage base registers
  10 
  11    The contents of the base registers are determined by the value
  12    of the type field as follows (P = variable field, N = constant field)
  13 
  14           0         EMPTY
  15           1         value of reference specified by P
  16           2         address of reference specified by P
  17           3         value of ptr contained at N in current stack
  18           4         ptr to display for block N levels back
  19           5         ptr to linkage section
  20           6         arg ptr for block P
  21           7         desc ptr for block P
  22           8         ptr thru link with offset N
  23           9         ptr to arg N in block P
  24          10         ptr to desc N in block P
  25          11         ptr to data of ext ctl variable with link N
  26          12         ptr to desc of ext ctl variable with link N
  27          13         ptr to static section
  28          14         ptr through ptr in static with offset N
  29 
  30    Initial Version: 16 April 1971 by BLW
  31           Modified:  11 May 1973 by RAB  for multiple base regs
  32           Modified: 19 June 1973 by RAB for EIS
  33           Modified: 19 July 1974 by RAB to load arg ptr in any reg
  34           Modified: 4 June 1975 by RAB for separate_static
  35           Modified: 20 August 1976 by RAB to fix 1512
  36           Modified: 22 January 1979 by RAB to fix 1814 (ERROR 313 for multiple
  37                     occurrences of based packed qualifier in if stmt)
  38                     prepare_operand now sets reference.evaluated after call to
  39                     base_man$load_packed
  40           Modified: 23 April 1979 by PCK to implement 4-bit decimal
  41           Modified: 2 September 1982 by BIM for load_aq_var
  42           Modified: June 1983 BIM for ref count fixes.
  43 */
  44 
  45 base_man$load_any_var:
  46      proc (code, var, base3);
  47 
  48 dcl       code                fixed bin,                    /* how to load */
  49           var                 ptr,                          /* ptr to ref */
  50           base3               bit (3) aligned;              /* set to base loaded */
  51 
  52 dcl       (i, j, k, n, text_pos, type, ca_code)
  53                               fixed bin,
  54           (vp, p, q)          ptr,
  55           (
  56           cg_stat$cur_level,
  57           cg_stat$text_pos,
  58           cg_stat$last_base_used
  59           )                   fixed bin ext,
  60           cg_stat$separate_static
  61                               bit (1) aligned ext static,
  62           (
  63           cg_stat$text_base,
  64           cg_stat$cur_statement
  65           )                   ptr ext static,
  66           (addressable, atomic)
  67                               bit (1) aligned,
  68           eis                 bit (1) aligned,
  69           lock                bit (1) aligned init ("0"b),
  70           tag_hold            bit (6) aligned,
  71           fract_offset        fixed bin,
  72           xr                  fixed bin (3),
  73           base                bit (3) aligned,
  74           full_word           bit (36) aligned based,
  75           macro               fixed bin (15),
  76           load                entry (ptr, fixed bin),
  77           prepare_operand     entry (ptr, fixed bin, bit (1) aligned) returns (ptr),
  78           copy_temp           entry (ptr) returns (ptr),
  79           base_to_core        entry (fixed bin, ptr),
  80           base_man$load_var   entry (fixed bin, ptr, fixed bin),
  81           base_man$load_display
  82                               entry (fixed bin, bit (3) aligned),
  83           base_man$load_linkage
  84                               entry (bit (3) aligned),
  85           base_man$load_arg   entry (fixed bin, ptr, bit (3) aligned),
  86           base_man$load_any_var
  87                               entry (fixed bin, ptr, bit (3) aligned),
  88           base_man$load_link_indirect
  89                               entry (fixed bin, bit (12) aligned, bit (3) aligned),
  90           xr_man$load_any_const
  91                               entry (fixed bin, fixed bin (3)),
  92           xr_man$add_any_const
  93                               entry (fixed bin, fixed bin (3), fixed bin (3)),
  94           m_a                 entry (ptr, bit (2) aligned),
  95           c_a                 entry (fixed bin, fixed bin) returns (ptr),
  96           compile_exp$save    entry (ptr) returns (ptr),
  97           get_reference       entry () returns (ptr),
  98           adjust_ref_count    entry (ptr, fixed bin),
  99           expmac              entry (fixed bin (15), ptr),
 100           expmac$zero         entry (fixed bin (15)),
 101           error               entry (fixed bin, ptr, ptr);
 102 
 103 declare   new_base            bit (3) aligned;
 104 declare   a_q_aq              fixed bin;                    /* Zero, one, two */
 105 declare   want_a_PR           bit (1) aligned init ("1"b);
 106 
 107 dcl       (abs, addrel, bit, fixed, mod, null, string, substr)
 108                               builtin;
 109 
 110 dcl       (
 111           first_base          init (3),
 112           last_base           init (6)
 113           )                   fixed bin (3) int static options (constant);
 114 
 115 dcl       (
 116           load_base           (0:1, 6) init (60, 361, 618, 619, 620, 621,
 117                                                             /* unpacked */
 118                               636, 637, 638, 639, 640, 641),/* packed */
 119           store_base          (23:24, 6) init (61, 409, 622, 623, 624, 625,
 120                                                             /* unpacked */
 121                               630, 631, 632, 633, 634, 635) /* packed */
 122           )                   fixed bin (15) int static options (constant);
 123 
 124 
 125 declare   e_a_q_aq_mac        (0:2) init (370, 371, 376) fixed bin (15) int static options (constant);
 126 
 127 dcl       add_base            (3) init (643, 736, 644) fixed bin (15) int static options (constant);
 128 
 129 dcl       (
 130           load_bp             init (60),
 131           store_bp            init (61),
 132           load_lp             init (361),
 133           packed_into_bp      init (584),
 134           stfx1               init (15),
 135           load_link_ptr       init (283)
 136           )                   fixed bin (15) int static options (constant);
 137 
 138 dcl       stack_info          (0:1) fixed bin int static options (constant) init (26,
 139                                                             /* stack offset of arg list */
 140                               34);                          /* stack offset of desc list */
 141 
 142 dcl       link_info           (0:1) fixed bin int static options (constant) init (36,
 143                                                             /* stack offset of linkage ptr */
 144                               28);                          /* stack offset of static ptr */
 145 
 146 dcl       display_offset      fixed bin int static init (32) options (constant);
 147 
 148 %include op_codes;
 149 %include operator;
 150 %include block;
 151 %include machine_state;
 152 %include symbol;
 153 %include cg_reference;
 154 %include bases;
 155 %include relocation_bits;
 156 %include nodes;
 157 %include boundary;
 158 %include cgsystem;
 159 
 160 /* This entry handles types 1 -3 and only loads bp */
 161 
 162 begin:
 163           n = code;                                         /* see list of values above */
 164           j, k = -1;
 165           want_a_PR = "1"b;
 166           go to load_any_var_load_aq_common;
 167 
 168 load_aq_var:
 169      entry (var);
 170 
 171 /* ASSUMPTIONS: this will only be called with pointer values */
 172 
 173           n = 1;
 174           j, k = -1;
 175           want_a_PR = "0"b;
 176           a_q_aq = 2;                                       /* AQ */
 177           go to load_any_var_load_aq_common;
 178 
 179 load_a_var:
 180      entry (var);
 181 
 182           n = 1;
 183           j, k = -1;
 184           want_a_PR = "0"b;
 185           a_q_aq = 0;
 186           go to load_any_var_load_aq_common;
 187 
 188 load_q_var:
 189      entry (var);
 190 
 191           n = 1;
 192           j, k = -1;
 193           want_a_PR = "0"b;
 194           a_q_aq = 1;
 195 
 196 load_any_var_load_aq_common:
 197           vp = var;
 198 
 199 /* Search the registers to see if we already have the registers */
 200 
 201           do i = 1 to last_base;
 202                type = base_regs (i).type;
 203                if type = 0
 204                then k = i;
 205                else if type = n                             /* contains the address type */
 206                then if base_regs (i).variable = vp
 207                     then do;
 208                               if ^want_a_PR
 209                               then go to PR_to_AQ;
 210                               if ^vp -> reference.shared
 211                               then call adjust_ref_count (vp, -1);
 212                               base3 = bases (i);
 213                               go to reset_perm;
 214                          end;
 215           end;
 216 
 217 /* We must load a register */
 218 
 219           call when_to_m_a;
 220           if ^want_a_PR
 221           then go to load_AQ;
 222           i = get_free_base ();
 223           base3 = bases (i);
 224           go to l1a;
 225 
 226 PR_to_AQ:                                                   /* come here with the PR number in i */
 227           string (vp -> address) = ""b;
 228           vp -> address.base = bases (i);                   /* fix the reference */
 229           vp -> address.ext_base = "1"b;
 230           vp -> reference.perm_address = "1"b;
 231           vp -> reference.relocation = ""b;                 /* Has to be absolute, its XXXX prn|0 */
 232           call expmac (e_a_q_aq_mac (a_q_aq), vp);
 233           go to AQ_finish;
 234 
 235 load_AQ:
 236           if ^addressable
 237           then do;
 238                     call m_a (vp, "00"b);
 239                     vp -> reference.perm_address = "1"b;
 240                end;
 241 
 242           if substr (vp -> address.tag, 1, 2)               /* Is there a star ? */
 243           then do;
 244                     if ^vp -> reference.shared
 245                     then vp -> reference.ref_count = vp -> reference.ref_count + 1;
 246                     call base_man$load_any_var (n, var, new_base);
 247                     i = which_base (bin (new_base, 3));
 248                     go to PR_to_AQ;
 249                end;
 250 
 251           substr (vp -> address.tag, 1, 2) = "01"b;         /* convert to RI mod */
 252           call expmac (e_a_q_aq_mac (a_q_aq), vp);
 253 
 254 AQ_finish:
 255           vp -> reference.perm_address = "0"b;              /* force m_a to recalculate, since we may have patched the tag */
 256           return;
 257 
 258 base_man$load_any_var_and_lock:
 259      entry (code, var, base3);
 260 
 261           lock = "1"b;
 262           go to begin;
 263 
 264 
 265 base_man$load_var_and_lock:
 266      entry (code, var, which);
 267 
 268           lock = "1"b;
 269 
 270 
 271 base_man$load_var:
 272      entry (code, var, which);
 273 
 274 dcl       which               fixed bin;                    /* which base to load */
 275 
 276           i = which;
 277           j, k = -1;
 278 
 279           vp = var;
 280           n = code;
 281           call when_to_m_a;
 282 
 283 /* See if item is already in a pointer register */
 284 
 285           do k = 1 to last_base;
 286                if base_regs (k).type = n
 287                then if base_regs (k).variable = vp
 288                     then if k = i
 289                          then do;
 290                                    if ^vp -> reference.shared
 291                                    then call adjust_ref_count (vp, -1);
 292                                    go to reset_perm;
 293                               end;
 294                          else j = k;
 295           end;
 296 
 297 /* Section to load the pointer register */
 298 
 299 
 300           do;
 301                cg_stat$last_base_used = i;
 302 l1a:
 303                macro = load_base (0, i);
 304 
 305 /* If we have the item in another pointer register, move it over */
 306 
 307                if j >= 0
 308                then do;
 309                          call change_base (i);
 310                          p = c_a (0, 4);
 311                          p -> address.base = bases (j);
 312                          call expmac (macro, p);
 313                          if ^vp -> reference.shared
 314                          then call adjust_ref_count (vp, -1);
 315                          if n = 2
 316                          then do;
 317                                    vp -> reference.address_in.b (i) = "1"b;
 318                                    go to l2;
 319                               end;
 320                          else go to l1b;
 321                     end;
 322 
 323 /*  To get the item, we must make it addressable */
 324 
 325                if ^addressable
 326                then do;
 327                          call m_a (vp, "0"b || eis);
 328                          vp -> reference.perm_address = "1"b;
 329                     end;
 330 
 331                call change_base (i);
 332 
 333 
 334                if n = 2
 335                then do;
 336 
 337                          if eis
 338                          then do;                           /* mask out the tag */
 339                                    tag_hold = vp -> address.tag & "001111"b;
 340                                    vp -> address.tag = vp -> address.tag & "010000"b;
 341                               end;
 342 
 343                          call expmac (macro, vp);
 344 
 345                          if vp -> reference.units ^= word_
 346                          then do;
 347                                    macro = add_base (vp -> reference.units);
 348                                    p = get_reference ();
 349                                    string (p -> reference.address) = bases (i);
 350                                    p -> address.ext_base = "1"b;
 351                                    p -> reference.relocation = "0"b;
 352                                    p -> reference.perm_address = "1"b;
 353 
 354                                    if eis
 355                                    then do;
 356                                              if vp -> reference.c_f_offset ^= 0
 357                                              then call add_cfo;
 358                                              p -> address.tag = tag_hold;
 359                                         end;
 360                                    else do;
 361                                              fract_offset =
 362                                                   mod (vp -> reference.c_offset, units_per_word (vp -> reference.units));
 363                                              if fract_offset < 0
 364                                              then fract_offset = fract_offset + units_per_word (vp -> reference.units);
 365                                              call xr_man$load_any_const (fract_offset, xr);
 366                                              p -> address.tag = "001"b || bit (xr, 3);
 367                                         end;
 368 
 369                                    if p -> address.tag
 370                                    then call exp_addmac;
 371                               end;
 372 
 373                          if vp -> reference.symbol ^= null
 374                          then do;
 375                                    string (vp -> reference.address) = bases (i);
 376                                    vp -> address.ext_base = "1"b;
 377                                    vp -> reference.relocation = "0"b;
 378                                    vp -> reference.c_f_offset = 0;
 379                                    vp -> reference.ic_ref = "0"b;
 380                               end;
 381 
 382                          vp -> reference.address_in.b (i) = "1"b;
 383 
 384                          goto l2;
 385                     end;
 386 
 387                if substr (vp -> address.tag, 1, 2)
 388                then do;
 389                          if ^vp -> reference.shared
 390                          then vp -> reference.ref_count = vp -> reference.ref_count + 1;
 391                          call expmac (macro, vp);
 392                          string (vp -> reference.address) = bases (i);
 393                          vp -> address.ext_base = "1"b;
 394                          vp -> address.tag = "010000"b;     /* * */
 395                          vp -> reference.relocation = "0"b;
 396                     end;
 397                else substr (vp -> address.tag, 1, 2) = "01"b;
 398                                                             /* convert to RI mod */
 399 
 400                call expmac (macro, vp);
 401 
 402 l1b:
 403                vp -> reference.value_in.b (i) = "1"b;
 404 l2:
 405                base_regs (i).variable = vp;
 406 
 407                base_regs (i).type = n;
 408                if lock
 409                then base_regs (i).locked = base_regs (i).locked + 1;
 410                else base_regs (i).locked = 0;
 411 
 412           end;
 413 
 414 reset_perm:
 415           if vp -> reference.symbol ^= null
 416           then vp -> reference.perm_address = "0"b;
 417 
 418 used_i:
 419           base_regs (i).used = cg_stat$text_pos;
 420           return;
 421 
 422 base_man$load_stack_indirect:
 423      entry (code, base2);
 424 
 425           n = code;
 426 
 427           k = -1;
 428           do i = 1 to last_base;
 429                type = base_regs (i).type;
 430                if type = 0
 431                then k = i;
 432                else if type = 3
 433                then if base_regs (i).constant = n
 434                     then go to l8;
 435           end;
 436 
 437           i = get_free_base ();
 438 
 439 
 440           call change_base (i);
 441 
 442           vp = c_a (n, 14);                                 /* sp|n,* */
 443           call expmac ((load_base (0, i)), vp);
 444 
 445           base_regs (i).type = 3;
 446           base_regs (i).constant = n;
 447 
 448 l8:
 449           base2 = bases (i);
 450           goto used_i;
 451 
 452 base_man$load_display:
 453      entry (frames, base2);
 454 
 455 dcl       frames              fixed bin,                    /* number of frames */
 456           base2               bit (3) aligned;              /* set to base loaded */
 457 
 458 dcl       (fmin, nframes)     fixed bin;
 459 
 460           j, k = -1;
 461           n, fmin = frames;
 462 
 463 /* Search for a register with a display pointer already loaded */
 464 
 465           do i = 1 to last_base;
 466                type = base_regs (i).type;
 467                if type = 0
 468                then k = i;
 469                else if type = 4
 470                then do;
 471                          if base_regs (i).constant = n
 472                          then go to l6;
 473                          if base_regs (i).constant < n
 474                          then do;
 475                                    nframes = n - base_regs (i).constant;
 476                                    if nframes < fmin
 477                                    then do;
 478                                              fmin = nframes;
 479                                              j = i;
 480                                         end;
 481                               end;
 482                     end;
 483           end;
 484 
 485           i = get_free_base ();
 486 
 487 /* Get first pointer in the chain */
 488 
 489           call change_base (i);
 490 
 491           vp = c_a (display_offset, 14);                    /* sp|32,* */
 492           if j > 0
 493           then vp -> address.base = bases (j);
 494           macro = load_base (0, i);
 495 
 496           call expmac (macro, vp);
 497 
 498 /* If necessary, follow the chain */
 499 
 500           if fmin > 1
 501           then do;
 502                     vp -> address.base = bases (i);
 503                     do j = 2 to fmin;
 504                          call expmac (macro, vp);
 505                     end;
 506                end;
 507 
 508 
 509           base_regs (i).type = 4;
 510           base_regs (i).constant = frames;
 511 
 512 l6:
 513           base2 = bases (i);
 514           go to used_i;
 515 
 516 
 517 base_man$load_static:
 518      entry (base1);
 519 
 520           if cg_stat$separate_static
 521           then do;
 522                     n = 13;
 523                     j = 1;
 524                     ca_code = 4;
 525                     go to link_join;
 526                end;
 527 
 528 
 529 base_man$load_linkage:
 530      entry (base1);
 531 
 532 dcl       base1               bit (3) aligned;              /* set to base loaded */
 533 
 534           n = 5;
 535           j = 0;
 536           ca_code = 14;
 537 link_join:
 538           k = -1;
 539 
 540 /* search for a register with ptr already loaded */
 541 
 542           do i = 2 to last_base;
 543                type = base_regs (i).type;
 544                if type = 0
 545                then k = i;
 546                else if type = n
 547                then go to set_base1;
 548           end;
 549 
 550 /* we prefer to use the lp */
 551 
 552           if base_regs (2).type < 5
 553           then i = 2;
 554           else i = get_free_base ();
 555 
 556 /* flush register i */
 557 
 558           call change_base (i);
 559 
 560 /* load the register from the correct offset */
 561 
 562           vp = c_a ((link_info (j)), ca_code);
 563           call expmac ((load_base (j, i)), vp);
 564           base_regs (i).type = n;
 565 
 566 set_base1:
 567           base1 = bases (i);
 568           base_regs (i).used = cg_stat$text_pos;
 569           return;
 570 
 571 
 572 base_man$load_arg:
 573      entry (code, blk_pt, base3);
 574 
 575 dcl       blk_pt              ptr;                          /* points at a blk node */
 576 
 577           vp = blk_pt;
 578 
 579           j = code + 6;
 580 
 581           do i = 1 to last_base;
 582                if base_regs (i).type = j
 583                then if base_regs (i).variable = vp
 584                     then go to l7;
 585           end;
 586 
 587           n = cg_stat$cur_level - vp -> block.level;
 588           if n = 0
 589           then base = sp;
 590           else call base_man$load_display (n, base);
 591 
 592           call setk;
 593 
 594           i = get_free_base ();
 595 
 596           if vp -> block.no_stack
 597           then n = vp -> block.entry_info + 2 + 2 * code;
 598           else n = stack_info (code);
 599 
 600           call change_base (i);
 601 
 602           p = c_a (n, 14);
 603           p -> address.base = base;
 604           call expmac ((load_base (0, i)), p);
 605 
 606           base_regs (i).type = j;
 607           base_regs (i).variable = vp;
 608 
 609 l7:
 610           base3 = bases (i);
 611           goto used_i;
 612 
 613 base_man$load_link_indirect:
 614      entry (poff, reloc, base3);
 615 
 616 dcl       (poff, off)         fixed bin,                    /* offset in linkage or static section */
 617           reloc               bit (12) aligned;             /* relocation to use */
 618 
 619 dcl       multiple            fixed bin;
 620 
 621           off = poff;
 622 
 623           if reloc = rc_lp15
 624           then do;                                          /* link indirect */
 625                     n = 8;
 626                     j = 9;
 627                end;
 628           else do;                                          /* static indirect */
 629                     n = 14;
 630                     j = 15;
 631                end;
 632 
 633           do i = 1 to last_base;
 634                if base_regs (i).type = n
 635                then if base_regs (i).constant = off
 636                     then go to l10;
 637           end;
 638 
 639           vp = c_a (off, j);
 640 
 641           call setk;
 642 
 643           i = get_free_base ();
 644 
 645           call change_base (i);
 646 
 647 
 648           call expmac ((load_base (0, i)), vp);
 649 
 650           base_regs (i).type = n;
 651           base_regs (i).constant = off;
 652 
 653 l10:
 654           base3 = bases (i);
 655           go to used_i;
 656 
 657 base_man$load_controlled:
 658      entry (poff, desc, base3);
 659 
 660 dcl       desc                fixed bin;                    /* zero if data, otherwise desc */
 661 
 662           n = 11 + fixed (desc ^= 0, 1);
 663           off = poff;
 664 
 665           do i = 1 to last_base;
 666                if base_regs (i).type = n
 667                then if base_regs (i).constant = off
 668                     then go to l10;
 669           end;
 670 
 671           call base_man$load_link_indirect (off, (rc_lp15), base);
 672 
 673           call setk;
 674 
 675           i = get_free_base ();
 676 
 677           call change_base (i);
 678 
 679           p = c_a (desc, 14);
 680           p -> address.base = base;
 681           call expmac ((load_base (0, i)), p);
 682 
 683           base_regs (i).type = n;
 684           base_regs (i).constant = off;
 685 
 686           goto l10;
 687 
 688 base_man$load_arg_ptr:
 689      entry (code, blk_pt, argno, base4);
 690 
 691 dcl       argno               fixed bin,                    /* which arg */
 692           base4               bit (3) aligned;              /* set to base loaded */
 693 
 694           vp = blk_pt;
 695 
 696           n = code + 9;
 697 
 698           do i = 1 to last_base;
 699                type = base_regs (i).type;
 700                if type = n
 701                then if base_regs (i).variable = vp
 702                     then if base_regs (i).constant = argno
 703                          then go to l9;
 704           end;
 705 
 706           call base_man$load_arg (code, blk_pt, base);
 707 
 708           call setk;
 709 
 710           i = get_free_base ();
 711 
 712           call change_base (i);
 713 
 714           p = c_a (2 * (argno - code), 14);
 715           p -> address.base = base;
 716 
 717           call expmac ((load_base (0, i)), p);
 718 
 719           base_regs (i).type = n;
 720           base_regs (i).variable = vp;
 721           base_regs (i).constant = argno;
 722 
 723 l9:
 724           base4 = bases (i);
 725           goto used_i;
 726 
 727 base_man$store_ptr_to:
 728      entry (pa, pb);
 729 
 730 /* this entry is called to store a ptr to reference pa in
 731              reference pb */
 732 
 733 dcl       (pa, pb)            ptr;
 734 
 735           do i = 1 to last_base;
 736                if base_regs (i).type = 2
 737                then if base_regs (i).variable = pa
 738                     then do;
 739                               if ^pa -> reference.shared
 740                               then call adjust_ref_count (pa, -1);
 741                               go to store;
 742                          end;
 743           end;
 744 
 745           i = 1;
 746 
 747           call base_man$load_var (2, pa, i);
 748 
 749 store:
 750           if pb -> reference.symbol ^= null
 751           then call base_to_core (i, pb);
 752           else do;
 753                     call expmac ((store_base (23, i)), pb);
 754                     if pb -> reference.temp_ref
 755                     then pb -> reference.value_in.storage = "1"b;
 756                end;
 757 
 758           return;
 759 
 760 base_man$update_base:
 761      entry (code, var, which);
 762 
 763 /* This entry is called to update the contents of the base register state */
 764 
 765           i = which;
 766           call change_base (i);
 767 
 768           vp = var;
 769           n = code;
 770 
 771           if n = 2
 772           then do;
 773                     vp -> reference.address_in.b (i) = "1"b;
 774                     goto l2;
 775                end;
 776 
 777           if n = 1
 778           then goto l1b;
 779 
 780           if n >= 5 & n <= 7
 781           then do;
 782                     base_regs (i).type = n;
 783                     base_regs (i).variable = vp;
 784                     go to used_i;
 785                end;
 786           else base_regs (i).type = 0;
 787           return;
 788 
 789 base_man$load_packed:
 790      entry (pa, where);
 791 
 792 /* This entry is called when an assigment from packed ptr to unpacked ptr is
 793              found as the qualifier of a reference node, or when such an assignment is
 794              found elsewhere.  The packed ptr is loaded into any register. */
 795 
 796 dcl       where               fixed bin;
 797 
 798           n = 1;
 799 
 800           p = pa;
 801           vp = p -> operand (1);
 802 
 803           if vp -> reference.shared & vp -> reference.symbol -> symbol.temporary
 804           then vp, p -> operand (1) = copy_temp (vp);
 805 
 806           vp = prepare_operand (vp, 1, atomic);
 807 
 808 
 809           q = prepare_operand ((p -> operand (2)), 1, atomic);
 810 
 811           if ^atomic
 812           then q = compile_exp$save ((p -> operand (2)));
 813 
 814           k = -1;
 815           do i = first_base to last_base;
 816                if base_regs (i).type = 0
 817                then k = i;
 818                else if q -> reference.temp_ref
 819                then if base_regs (i).type = 1
 820                     then if base_regs (i).variable = q
 821                          then do;
 822                                    where = i;
 823                                    call adjust_ref_count (q, -1);
 824                                    go to used_i;
 825                               end;
 826           end;
 827 
 828           if q -> reference.temp_ref
 829           then if ^q -> reference.value_in.storage
 830                then if q -> reference.value_in.q
 831                     then do;
 832                               q -> reference.ref_count = q -> reference.ref_count + 1;
 833                               q -> reference.store_ins = bit (cg_stat$text_pos, 18);
 834                               call expmac ((stfx1), q);
 835                               q -> reference.value_in.storage = "1"b;
 836                          end;
 837                     else call error (315, cg_stat$cur_statement, q);
 838 
 839           p = vp;
 840           vp = q;
 841 
 842           call when_to_m_a;
 843           i = get_free_base ();
 844 
 845           where = i;
 846 
 847           call change_base (i);
 848 
 849           call expmac ((load_base (1, i)), vp);
 850 
 851           vp = p;
 852           go to l1b;
 853 
 854 
 855 base_man$lock:
 856      entry (lbase);
 857 dcl       lbase               fixed bin;
 858           base_regs (lbase).locked = base_regs (lbase).locked + 1;
 859           return;
 860 
 861 base_man$unlock:
 862      entry (lbase);
 863           base_regs (lbase).locked = base_regs (lbase).locked - 1;
 864           return;
 865 
 866 
 867 
 868 /*^L */
 869 when_to_m_a:
 870      proc;
 871 dcl       p                   ptr;
 872 
 873 /* Decide whether we must make vp addressable before looking for a free base
 874    register and loading it */
 875 
 876           eis = "0"b;
 877           addressable = ^vp -> reference.no_address & vp -> reference.perm_address;
 878           if string (vp -> reference.value_in.b)
 879           then return;
 880           if string (vp -> reference.address_in.b)
 881           then return;
 882 
 883           if n = 2
 884           then if vp -> reference.units ^= word_
 885                then if ^vp -> reference.modword_in_offset
 886                     then eis = "1"b;
 887 
 888           if addressable
 889           then return;
 890 
 891           do p = vp -> reference.qualifier repeat p -> reference.qualifier while (p ^= null);
 892                if p -> node.type = temporary_node
 893                then return;
 894                if p -> node.type = operator_node
 895                then do;
 896                          if p -> operator.op_code = param_ptr
 897                          then go to call_ma;
 898                          p = p -> operand (1);
 899                     end;
 900                if string (p -> reference.value_in.b)
 901                then go to call_ma;
 902                if string (p -> reference.address_in.b)
 903                then go to call_ma;
 904                if p -> reference.ref_count > 1
 905                then do;
 906 call_ma:
 907                          call m_a (vp, "0"b || eis);
 908                          vp -> reference.perm_address = "1"b;
 909                          addressable = "1"b;
 910                          if k >= first_base
 911                          then if base_regs (k).type ^= 0
 912                               then call setk;
 913                          return;
 914                     end;
 915           end;
 916      end;
 917 
 918 
 919 
 920 /*^L */
 921 get_free_base:
 922      proc () returns (fixed bin);
 923 
 924 /* If an empty register was found in the scan, use that; otherwise pick a
 925    register containing a variable with the lowest reference count, priority, and
 926    least recently used */
 927 
 928 dcl       (i, j, cmin, n, pr, pmin, type)
 929                               fixed bin;
 930 dcl       p                   ptr;
 931 dcl       priority            (14) fixed bin int static init (3, 3, 2, 4, 5, 4, 3, 2, 3, 1, 3, 1, 5, 2);
 932 
 933 /* Variable k lives in the outer block */
 934 
 935           if k >= first_base
 936           then if base_regs (k).locked = 0
 937                then do;
 938                          cg_stat$last_base_used = k;
 939                          return (k);
 940                     end;
 941 
 942           j = -1;
 943           cmin = 123456;
 944           do i = max (cg_stat$last_base_used + 1, first_base) to last_base, first_base to cg_stat$last_base_used;
 945                if base_regs (i).locked > 0
 946                then go to try_another;
 947 
 948                type = base_regs (i).type;
 949                if type = 0
 950                then do;
 951 hit:
 952                          cg_stat$last_base_used = i;
 953                          return (i);
 954                     end;
 955 
 956                p = base_regs (i).variable;
 957 
 958                if type < 3
 959                then do;
 960                          if p = null
 961                          then go to hit;
 962                          n = p -> reference.ref_count;
 963 
 964                          if ^p -> reference.shared
 965                          then if n <= 0
 966                               then go to hit;
 967                               else ;
 968                          else if p -> reference.temp_ref
 969                          then go to hit;
 970 
 971                          pr = 3;
 972                     end;
 973                else do;
 974                          n = 0;
 975                          pr = priority (type);
 976                     end;
 977 
 978                if n < cmin
 979                then do;
 980                          cmin = n;
 981 sj:
 982                          pmin = pr;
 983                          j = i;
 984                     end;
 985                else if n = cmin
 986                then if pr < pmin
 987                     then go to sj;
 988                     else if pr = pmin
 989                     then if base_regs (i).used < base_regs (j).used
 990                          then go to sj;
 991 try_another:
 992           end;
 993 
 994           cg_stat$last_base_used = j;
 995           return (j);
 996      end;
 997 
 998 
 999 
1000 
1001 /*^L */
1002 
1003 change_base:
1004      proc (m);
1005 
1006 dcl       (m, n, t)           fixed bin,
1007           p                   ptr;
1008 
1009           n = m;
1010           p = base_regs (n).variable;
1011           if p = null
1012           then return;
1013 
1014           t = base_regs (n).type;
1015 
1016           if t = 2
1017           then do;
1018                     p -> reference.address_in.b (n) = "0"b;
1019                     return;
1020                end;
1021 
1022           if t ^= 1
1023           then return;
1024 
1025           p -> reference.value_in.b (n) = "0"b;
1026 
1027           if ^p -> reference.temp_ref
1028           then return;
1029           if p -> reference.value_in.storage
1030           then return;
1031           if p -> reference.dont_save
1032           then return;
1033 
1034           if p -> reference.ref_count > 0
1035           then do;
1036                     p -> reference.ref_count = p -> reference.ref_count + 1;
1037                     p -> reference.store_ins = bit (cg_stat$text_pos, 18);
1038                     call expmac ((store_base (p -> reference.data_type, n)), p);
1039                     p -> reference.value_in.storage = "1"b;
1040                end;
1041 
1042      end;                                                   /*^L */
1043 setk:
1044      proc;
1045 
1046           k = -1;
1047           do i = last_base to first_base by -1;
1048                if base_regs (i).type = 0
1049                then do;
1050                          k = i;
1051                          return;
1052                     end;
1053           end;
1054 
1055      end;                                                   /*^L*/
1056 exp_addmac:
1057      proc;
1058 
1059 /* Issues add bits or bytes to pointer macro */
1060 
1061           text_pos = cg_stat$text_pos;
1062 
1063           call expmac (macro, p);
1064 
1065           base_regs (i).changed = text_pos;
1066           base_regs (i).instruction = addrel (cg_stat$text_base, text_pos) -> full_word;
1067      end;
1068 
1069 
1070 
1071 add_cfo:
1072      proc;
1073 
1074 /* routine to add in constant_fractional_offset if not already done */
1075 
1076           if substr (tag_hold, 3, 1)
1077           then do;
1078                     call xr_man$add_any_const ((vp -> reference.c_f_offset), xr, fixed (substr (tag_hold, 4, 3), 3));
1079                     tag_hold = "001"b || bit (xr, 3);
1080                end;
1081           else do;
1082                     call xr_man$load_any_const ((vp -> reference.c_f_offset), xr);
1083                     p -> address.tag = "001"b || bit (xr, 3);
1084                     call exp_addmac;
1085                end;
1086      end;
1087 
1088      end base_man$load_any_var;