1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) BULL HN Information Systems Inc., 1989   *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Bull Inc., 1987                *
   6         *                                                         *
   7         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   8         *                                                         *
   9         * Copyright (c) 1972 by Massachusetts Institute of        *
  10         * Technology and Honeywell Information Systems, Inc.      *
  11         *                                                         *
  12         *********************************************************** */
  13 
  14 
  15 /****^  HISTORY COMMENTS:
  16   1) change(87-02-27,Huen), approve(87-02-27,MCR7625), audit(87-02-27,RWaters),
  17      install(87-05-21,MR12.1-1033):
  18      Fix High priority
  19      bug2106 ::  When a PL/1 stack frame is larger than 2 ** 14 words, bad code
  20      is generated for the put_edit statement.
  21   2) change(89-07-28,JRGray), approve(89-07-28,MCR8123), audit(89-09-12,Vu),
  22      install(89-09-22,MR12.3-1073):
  23      Added the state_man_$save_regs ep to save temp values (pl1 2091 2177).
  24                                                    END HISTORY COMMENTS */
  25 /* Procedure to manage the machine state nodes
  26 
  27    Initial Version: 27 April 1971 by BLW
  28           Modified:  4 November 1972 by BLW
  29           Modified:  15 February 1973 by RAB
  30           Modified: 11 June 1973 by RAB for EIS
  31           Modified: 29 May 1974 by RAB to save the string aq
  32           Modified: 16 November 1974 by RAB to fix bug 1223
  33           Modified: 18 November 1974 by RAB to fix 1258
  34           Modified: 5 June 1975 by RAB for separate_static
  35           Modified: 13 October 1975 by RAB to remember comparisons
  36           Modified: 1 November 1975 by RAB to check save_temps bit
  37           Modified: 24 November 1975 by RAB to check aggregate bit in save_temp
  38           Modified: 8 January 1976 by RAB to fix bug 1452 in merge_ms
  39           Modified: 29 April 1976 by RAB to fix bug 1494
  40           Modified: 23 June 1976 by RAB to centralize use of cg_stat$last_call
  41           Modified: 25 March 1977 by RAB to fix 1599
  42           Modified: April 1977 by RHS to change allocation scheme of xeq_tree_area
  43           Modified: 1 May 1977 by RAB to fix 1612
  44           Modified: 1 September 1977 by RAB to add state_man$flush_sym in order to fix 1664
  45           Modified 780717 by PG to count machine_state nodes allocated
  46           Modified: 7 August 1978 by RAB to fix 1751 by allowing save_temp to save complex_flt_bin_1 temps
  47           Modified: 30 January 1987 by SH&RW fixed bug 2106
  48 */
  49 
  50 state_man$create_ms: proc (pt);
  51 
  52           dcl     pt                     ptr;               /* points at machine state node */
  53 
  54           dcl     (p, q)                 ptr,
  55                   sym                    ptr auto unal,
  56                   (erase, b19)           bit (19) aligned,
  57                   (prev_state, found)    bit (1) aligned,
  58                   text_pos               fixed bin (18),
  59                   (i, j, n)              fixed bin;
  60 
  61           dcl     (cg_stat$ms_list, cg_stat$m_s_p) ptr ext,
  62                   (cg_stat$text_pos, cg_stat$last_call) fixed bin (18) ext,
  63                   pl1_stat_$node_uses    (18) fixed bin external static;
  64 
  65           dcl     c_a                    entry (fixed bin (18), fixed bin) returns (ptr),
  66                   expmac                 entry (fixed bin (15), ptr),
  67                   expmac$one             entry (fixed bin (15), ptr, fixed bin (15)),
  68                   expmac$one_eis         entry (fixed bin (15), ptr),
  69                   stack_temp$assign_block entry (ptr, fixed bin);
  70 
  71           dcl     (abs, bin, bit, fixed, index, min, mod, null, string, substr) builtin;
  72 
  73 %include pl1_tree_areas;
  74 %include cgsystem;
  75 %include machine_state;
  76 %include reference;
  77 %include symbol;
  78 %include operator;
  79 %include list;
  80 %include statement;
  81 %include block;
  82 %include nodes;
  83 %include data_types;
  84 %include boundary;
  85 %include temporary;
  86 
  87           call get_ms;
  88           pt = m_s_p;
  89 
  90 init:     machine_state.next,
  91                string_reg.variable,
  92                complex_reg.variable,
  93                decimal_reg.variable = null;
  94 
  95           do i = 0 to 7;
  96                index_regs (i).type = 0;
  97                base_regs (i).type = 0;
  98                base_regs (i).locked = 0;
  99           end;
 100 
 101 init1:    machine_state.indicators,
 102                a_reg.constant,
 103                q_reg.constant,
 104                a_reg.number_h_o,
 105                q_reg.number_h_o,
 106                a_reg.number,
 107                q_reg.number,
 108                a_reg.changed,
 109                q_reg.changed = 0;
 110 
 111           a_reg.locked,
 112                q_reg.locked,
 113                a_reg.instruction,
 114                q_reg.instruction = "0"b;
 115 
 116           cg_stat$last_call = cg_stat$text_pos;
 117 
 118           return;
 119 
 120 state_man$save_ms: entry (pt, cond);
 121 
 122 /* this entry is called to append a copy of the current machine
 123              state to the list of states on a specified statement node */
 124 
 125           dcl     cond                   bit (1) aligned;   /* "1"b if transfer is conditional */
 126 
 127           dcl     (conditional, optimize) bit (1) aligned;
 128 
 129           p = pt;
 130           optimize = ^p -> statement.save_temps;
 131 
 132           conditional = cond;
 133 
 134           if conditional
 135           then do;
 136                     call get_ms;
 137                     m_s_p -> machine_state = cg_stat$m_s_p -> machine_state;
 138                end;
 139 
 140           machine_state.next = p -> statement.state_list;
 141           p -> statement.state_list = m_s_p;
 142           p -> statement.reference_count = p -> statement.reference_count - 1;
 143 
 144           q = p -> statement.reference_list;
 145 
 146 /* see if any of the expressions in the active registers have to be
 147              saved because they will be needed at the statement being transfered
 148              to.  Also, turn off bit saying reference is in a register if this
 149              is forward unconditional transfer */
 150 
 151           do i = 1 to a_reg.number;
 152                p = a_reg.variable (i);
 153                if need_ref () then call save_temp (1);
 154                if ^conditional then p -> reference.value_in.a = "0"b;
 155           end;
 156 
 157           do i = 1 to q_reg.number;
 158                p = q_reg.variable (i);
 159                if need_ref () then call save_temp (2);
 160                if ^conditional then p -> reference.value_in.q = "0"b;
 161           end;
 162 
 163           do i = 0 to 7;
 164                if index_regs (i).type >= 2
 165                then do;
 166                          p = index_regs (i).variable;
 167                          if p ^= null
 168                          then do;
 169                                    if need_ref () then call save_temp (0);
 170                                    if ^conditional then p -> reference.value_in.x (i) = "0"b;
 171                               end;
 172                     end;
 173           end;
 174 
 175           do i = 1 to 6;
 176                p = base_regs (i).variable;
 177                n = base_regs (i).type;
 178                if p = null then n = 0;
 179                if n = 1
 180                then do;
 181                          if need_ref () then call save_temp (-i);
 182                          if ^conditional then p -> reference.value_in.b (i) = "0"b;
 183                     end;
 184                else if n = 2
 185                then if ^conditional then p -> reference.address_in.b (i) = "0"b;
 186           end;
 187 
 188           if ^conditional
 189           then do;
 190 
 191                     p = complex_reg.variable;
 192                     if p ^= null then p -> reference.value_in.complex_aq = "0"b;
 193 
 194                     p = string_reg.variable;
 195                     if p ^= null then p -> reference.value_in.string_aq = "0"b;
 196 
 197                     p = decimal_reg.variable;
 198                     if p ^= null then p -> reference.value_in.decimal_aq = "0"b;
 199 
 200                     cg_stat$m_s_p = null;
 201                end;
 202 
 203           cg_stat$last_call = cg_stat$text_pos;
 204 
 205           return;
 206 
 207 state_man$save_regs: entry (pt);
 208 
 209 /* This entrypoint will see if any of the expressions in the active
 210    registers have to be saved because they will be needed at the statement
 211    being transfered to.  This is part of the job that state_man$save_ms does
 212    but is done here so that register saving will not clobber the indicators.
 213    This occurs when another register (usually an X register) is loaded in
 214    order to get a big enough offset to store a useful register. (PL1 2091) */
 215 
 216           p = pt;
 217           optimize = ^p -> statement.save_temps;  /* used by need_ref */
 218           q = p -> statement.reference_list;      /* used by need_ref */
 219 
 220           do i = 1 to a_reg.number;
 221                p = a_reg.variable (i);
 222                if need_ref () then call save_temp (1);
 223           end;
 224 
 225           do i = 1 to q_reg.number;
 226                p = q_reg.variable (i);
 227                if need_ref () then call save_temp (2);
 228           end;
 229 
 230           do i = 0 to 7;
 231                if index_regs (i).type >= 2
 232                then do;
 233                          p = index_regs (i).variable;
 234                          if p ^= null then if need_ref () then call save_temp (0);
 235                     end;
 236           end;
 237 
 238           do i = 1 to 6;
 239                p = base_regs (i).variable;
 240                if p ^= null then
 241                     if base_regs (i).type = 1 then
 242                          if need_ref () then call save_temp (-i);
 243           end;
 244 
 245           return;   /* end of save_regs */
 246 
 247 state_man$merge_ms: entry (pt);
 248 
 249 /* this entry is called to merge the machine states
 250              attached to a statement node */
 251 
 252           if pt -> statement.reference_count = 0
 253           then erase = "0"b;
 254           else erase = (19)"1"b;
 255 
 256           p = pt -> statement.state_list;
 257 
 258           if m_s_p = null
 259           then do;
 260 
 261 /* previous statement was unconditional transfer */
 262 
 263                     if p = null
 264                     then do;
 265                               call get_ms;
 266                               cg_stat$m_s_p = m_s_p;
 267                               goto init;
 268                          end;
 269 
 270                     m_s_p, cg_stat$m_s_p = p;
 271                     p = machine_state.next;
 272                     prev_state = "0"b;
 273                end;
 274 
 275           else prev_state = "1"b;
 276 
 277           if erase
 278           then machine_state.indicators = 0;
 279 
 280           do while (p ^= null);
 281 
 282                if machine_state.indicators ^= p -> machine_state.indicators
 283                then machine_state.indicators = 0;
 284                else if machine_state.indicators = -2
 285                then if indicators_ref (2) ^= p -> indicators_ref (2)
 286                     then machine_state.indicators = 0;
 287                     else if indicators_ref (3) ^= p -> indicators_ref (3)
 288                     then machine_state.indicators = 0;
 289 
 290                if substr (erase, 1, 1) then goto scrub_a;
 291 
 292                if a_reg.size ^= p -> a_reg.size
 293                then do;
 294 erase_a:                 substr (erase, 1, 1) = "1"b;
 295 
 296 scrub_a:                 do j = 1 to p -> a_reg.number;
 297                               q = p -> a_reg.variable (j);
 298                               if q ^= null then q -> reference.value_in.a = "0"b;
 299                          end;
 300 
 301 
 302                          goto chk_q;
 303                     end;
 304 
 305                if a_reg.length ^= p -> a_reg.length then goto erase_a;
 306                if a_reg.offset ^= p -> a_reg.offset then goto erase_a;
 307                if a_reg.constant ^= p -> a_reg.constant then goto erase_a;
 308 
 309                n = a_reg.number;
 310                do i = 1 by 1 while (i <= n);
 311 
 312 scan_a:             q = a_reg.variable (i);
 313 
 314                     do j = 1 to p -> a_reg.number;
 315                          if q = p -> a_reg.variable (j)
 316                          then do;
 317                                    p -> a_reg.variable (j) = null;
 318                                    goto ok_a;
 319                               end;
 320                     end;
 321 
 322                     q -> reference.value_in.a = "0"b;
 323 
 324                     n = n - 1;
 325                     if n = 0 then goto erase_a;
 326                     if n < i then goto end_a;
 327 
 328                     do j = i to n;
 329                          a_reg.variable (j) = a_reg.variable (j + 1);
 330                     end;
 331 
 332                     goto scan_a;
 333 
 334 ok_a:          end;
 335 
 336 end_a:         a_reg.number = n;
 337 
 338 chk_q:         if substr (erase, 2, 1) then goto scrub_q;
 339 
 340                if q_reg.size ^= p -> q_reg.size
 341                then do;
 342 erase_q:                 substr (erase, 2, 1) = "1"b;
 343 
 344 scrub_q:                 do j = 1 to p -> q_reg.number;
 345                               q = p -> q_reg.variable (j);
 346                               if q ^= null then q -> reference.value_in.q = "0"b;
 347                          end;
 348                          goto chk_sr;
 349                     end;
 350 
 351                if q_reg.length ^= p -> q_reg.length then goto erase_q;
 352                if q_reg.offset ^= p -> q_reg.offset then goto erase_q;
 353                if q_reg.constant ^= p -> q_reg.constant then goto erase_q;
 354 
 355                n = q_reg.number;
 356                do i = 1 by 1 while (i <= n);
 357 
 358 scan_q:             q = q_reg.variable (i);
 359 
 360                     do j = 1 to p -> q_reg.number;
 361                          if q = p -> q_reg.variable (j)
 362                          then do;
 363                                    p -> q_reg.variable (j) = null;
 364                                    goto ok_q;
 365                               end;
 366                     end;
 367 
 368                     q -> reference.value_in.q = "0"b;
 369 
 370                     n = n - 1;
 371                     if n = 0 then goto erase_q;
 372                     if n < i then goto end_q;
 373 
 374                     do j = i to n;
 375                          q_reg.variable (j) = q_reg.variable (j + 1);
 376                     end;
 377 
 378                     goto scan_q;
 379 
 380 ok_q:          end;
 381 
 382 end_q:         q_reg.number = n;
 383 
 384 chk_sr:        if substr (erase, 3, 1) then goto scrub_sr;
 385 
 386                if string_reg.size ^= p -> string_reg.size
 387                then do;
 388 erase_sr:                substr (erase, 3, 1) = "1"b;
 389 
 390 scrub_sr:                q = p -> string_reg.variable;
 391                          if q ^= null then q -> reference.value_in.string_aq = "0"b;
 392                          goto chk_cx;
 393                     end;
 394 
 395                if string_reg.variable ^= p -> string_reg.variable then goto erase_sr;
 396 
 397 chk_cx:        if substr (erase, 4, 1) then goto scrub_cx;
 398 
 399                if complex_reg.size ^= p -> complex_reg.size
 400                then do;
 401 erase_cx:                substr (erase, 4, 1) = "1"b;
 402 
 403 scrub_cx:                q = p -> complex_reg.variable;
 404                          if q ^= null then q -> reference.value_in.complex_aq = "0"b;
 405                          goto chk_d;
 406                     end;
 407 
 408                if complex_reg.scale ^= p -> complex_reg.scale then goto erase_cx;
 409                if complex_reg.variable ^= p -> complex_reg.variable then goto erase_cx;
 410 
 411 chk_d:         if substr (erase, 5, 1) then goto scrub_d;
 412 
 413                if decimal_reg.size ^= p -> decimal_reg.size
 414                then do;
 415 erase_d:                 substr (erase, 5, 1) = "1"b;
 416 
 417 scrub_d:                 q = p -> decimal_reg.variable;
 418                          if q ^= null then q -> reference.value_in.decimal_aq = "0"b;
 419                          goto chk_xr;
 420                     end;
 421 
 422                if decimal_reg.scale ^= p -> decimal_reg.scale then goto erase_d;
 423                if decimal_reg.variable ^= p -> decimal_reg.variable then goto erase_d;
 424 
 425 chk_xr:        do i = 0 to 7;
 426 
 427                     if substr (erase, i + 6, 1) then goto scrub_xr;
 428 
 429                     n = index_regs (i).type;
 430                     if n ^= p -> index_regs (i).type
 431                     then do;
 432 erase_xr:                     substr (erase, i + 6, 1) = "1"b;
 433 
 434 scrub_xr:                     if p -> index_regs (i).type >= 2
 435                               then do;
 436                                         q = p -> index_regs (i).variable;
 437                                         if q ^= null then q -> reference.value_in.x (i) = "0"b;
 438                                    end;
 439 
 440                               goto end_xr;
 441                          end;
 442 
 443                     if n >= 2
 444                     then if index_regs (i).variable ^= p -> index_regs (i).variable
 445                          then goto erase_xr;
 446 
 447                     if index_regs (i).constant ^= p -> index_regs (i).constant then goto erase_xr;
 448 
 449 end_xr:        end;
 450 
 451 chk_base:      do i = 1 to 6;
 452 
 453                     if substr (erase, i + 13, 1) then goto scrub_base;
 454 
 455                     n = base_regs (i).type;
 456                     if n ^= p -> base_regs (i).type
 457                     then do;
 458 erase_base:                   substr (erase, i + 13, 1) = "1"b;
 459 
 460 scrub_base:                   q = p -> base_regs (i).variable;
 461 
 462                               n = p -> base_regs (i).type;
 463                               if q = null then n = 0;
 464                               if n = 1 then q -> reference.value_in.b (i) = "0"b;
 465                               else if n = 2 then q -> reference.address_in.b (i) = "0"b;
 466 
 467                               goto end_base;
 468                          end;
 469 
 470                     if n = 0 then goto end_base;
 471 
 472                     if substr ("11000110110000"b, n, 1)
 473                     then if base_regs (i).variable ^= p -> base_regs (i).variable
 474                          then goto erase_base;
 475 
 476                     if substr ("00110001111101"b, n, 1)
 477                     then if base_regs (i).constant ^= p -> base_regs (i).constant
 478                          then goto erase_base;
 479 
 480 end_base:      end;
 481 
 482                q = p;
 483                p = p -> machine_state.next;
 484 
 485                q -> machine_state.next = cg_stat$ms_list;
 486                cg_stat$ms_list = q;
 487           end;
 488 
 489           if erase
 490           then call wipe;
 491 
 492           if prev_state | (^erase = "0"b) then return;
 493 
 494           if a_reg.constant = 0
 495           then do i = 1 to a_reg.number;
 496                     a_reg (i).variable -> reference.value_in.a = "1"b;
 497                end;
 498 
 499           if q_reg.constant = 0
 500           then do i = 1 to q_reg.number;
 501                     q_reg (i).variable -> reference.value_in.q = "1"b;
 502                end;
 503 
 504           q = string_reg.variable;
 505           if q ^= null then q -> reference.value_in.string_aq = "1"b;
 506 
 507           q = complex_reg.variable;
 508           if q ^= null then q -> reference.value_in.complex_aq = "1"b;
 509 
 510           q = decimal_reg.variable;
 511           if q ^= null then q -> reference.value_in.decimal_aq = "1"b;
 512 
 513           do i = 0 to 7;
 514                if index_regs (i).type >= 2
 515                then if index_regs (i).constant = 0
 516                     then do;
 517                               q = index_regs (i).variable;
 518                               if q ^= null then q -> reference.value_in.x (i) = "1"b;
 519                          end;
 520           end;
 521 
 522           do i = 1 to 6;
 523                q = base_regs (i).variable;
 524                n = base_regs (i).type;
 525                if q = null then n = 0;
 526                if n = 1 then q -> reference.value_in.b (i) = "1"b;
 527                else if n = 2 then q -> reference.address_in.b (i) = "1"b;
 528           end;
 529 
 530           return;
 531 
 532 state_man$discard_ms: entry;
 533 
 534 /* this entry is called to discard the current machine state after
 535              an unconditional transfer back to a previously defined label */
 536 
 537           machine_state.next = cg_stat$ms_list;
 538           cg_stat$ms_list = m_s_p;
 539           cg_stat$m_s_p = null;
 540 
 541 /* now flush state */
 542 
 543 state_man$flush: entry;
 544 
 545 /* this entry is called to completely flush the machine state */
 546 
 547           machine_state.indicators = 0;
 548 
 549 /* save the index registers used by the operator */
 550 
 551           erase = ("1111100000000111111"b);
 552           call wipe;
 553 
 554 /* free all registers */
 555 
 556           erase = (19)"1"b;
 557           call wipe;
 558 
 559           cg_stat$last_call = cg_stat$text_pos;
 560           return;
 561 
 562 state_man$flush_ref: entry (pt);
 563 
 564 /* this entry is called to flush a particular reference from
 565              the machine state */
 566 
 567           p = pt;
 568 
 569           if machine_state.indicators = -2
 570           then if p = indicators_ref (2)
 571                then machine_state.indicators = 0;
 572                else if p = indicators_ref (3)
 573                then machine_state.indicators = 0;
 574 
 575 /* can't test reference.value_in because ref could
 576              be in reg with a constant added */
 577 
 578           n = a_reg.number;
 579           do i = 1 to n;
 580                if a_reg.variable (i) = p
 581                then do;
 582                          a_reg.number = n - 1;
 583 
 584                          do i = i + 1 to n;
 585                               a_reg.variable (i - 1) = a_reg.variable (i);
 586                          end;
 587 
 588                          goto frq;
 589                     end;
 590           end;
 591 
 592 frq:      n = q_reg.number;
 593           do i = 1 to n;
 594                if q_reg.variable (i) = p
 595                then do;
 596                          q_reg.number = n - 1;
 597 
 598                          do i = i + 1 to n;
 599                               q_reg.variable (i - 1) = q_reg.variable (i);
 600                          end;
 601 
 602                          goto frsr;
 603                     end;
 604           end;
 605 
 606 frsr:     if string_reg.variable = p then string_reg.variable = null;
 607 
 608           if complex_reg.variable = p then complex_reg.variable = null;
 609 
 610           if decimal_reg.variable = p then decimal_reg.variable = null;
 611 
 612           do i = 0 to 7;
 613                n = index_regs (i).type;
 614                if abs (n) >= 2
 615                then if index_regs (i).variable = p
 616                     then do;
 617                               index_regs (i).type = min (0, n);
 618                               index_regs (i).variable = null;
 619                          end;
 620           end;
 621 
 622           do i = 1 to 6;
 623                if base_regs (i).type = 1
 624                then if base_regs (i).variable = p
 625                     then base_regs (i).type = 0;
 626           end;
 627 
 628           string (p -> reference.value_in) = "0"b;
 629           return;
 630 
 631 state_man$flush_address: entry (pt);
 632 
 633 /* this entry is called to remove the address of a reference
 634              from the machine state  */
 635 
 636           p = pt;
 637 
 638           do i = 1 to 6;
 639                if base_regs (i).type = 2
 640                then if base_regs (i).variable = p
 641                     then base_regs (i).type = 0;
 642           end;
 643 
 644           string (p -> reference.address_in.b) = "0"b;
 645           return;
 646 
 647 state_man$flush_sym: entry (pt);
 648 
 649 /* this entry is called to flush all references to a particular
 650              symbol from the machine state.  it should be called whenever
 651              a short string is set by an EIS instruction (which does not
 652              alter a register). */
 653 
 654           sym = pt;
 655 
 656           if machine_state.indicators = -2
 657           then if sym = indicators_ref (2) -> reference.symbol
 658                then machine_state.indicators = 0;
 659                else if sym = indicators_ref (3) -> reference.symbol
 660                then machine_state.indicators = 0;
 661 
 662           i = 1;
 663           do while (i <= a_reg.number);
 664                if sym = a_reg.variable (i) -> reference.symbol
 665                then do;
 666                          a_reg.variable (i) -> reference.value_in.a = "0"b;
 667                          a_reg.number = a_reg.number - 1;
 668                          do j = i to a_reg.number;
 669                               a_reg.variable (j) = a_reg.variable (j + 1);
 670                          end;
 671                     end;
 672                else i = i + 1;
 673           end;
 674 
 675           i = 1;
 676           do while (i <= q_reg.number);
 677                if sym = q_reg.variable (i) -> reference.symbol
 678                then do;
 679                          q_reg.variable (i) -> reference.value_in.q = "0"b;
 680                          q_reg.number = q_reg.number - 1;
 681                          do j = i to q_reg.number;
 682                               q_reg.variable (j) = q_reg.variable (j + 1);
 683                          end;
 684                     end;
 685                else i = i + 1;
 686           end;
 687 
 688           if string_reg.variable ^= null
 689           then if sym = string_reg.variable -> reference.symbol
 690                then do;
 691                          string_reg.variable -> reference.value_in.string_aq = "0"b;
 692                          string_reg.variable = null;
 693                     end;
 694 
 695           if complex_reg.variable ^= null
 696           then if sym = complex_reg.variable -> reference.symbol
 697                then do;
 698                          complex_reg.variable -> reference.value_in.complex_aq = "0"b;
 699                          complex_reg.variable = null;
 700                     end;
 701 
 702           if decimal_reg.variable ^= null
 703           then if sym = decimal_reg.variable -> reference.symbol
 704                then do;
 705                          decimal_reg.variable -> reference.value_in.decimal_aq = "0"b;
 706                          decimal_reg.variable = null;
 707                     end;
 708 
 709           do i = 0 to 7;
 710                if abs (index_regs (i).type) >= 2
 711                then do;
 712                          q = index_regs (i).variable;
 713                          if sym = q -> reference.symbol
 714                          then do;
 715                                    q -> reference.value_in.x (i) = "0"b;
 716                                    index_regs (i).type = 0;
 717                               end;
 718                     end;
 719           end;
 720 
 721           do i = 1 to 6;
 722                if base_regs (i).type = 1
 723                then do;
 724                          q = base_regs (i).variable;
 725                          if sym = q -> reference.symbol
 726                          then do;
 727                                    q -> reference.value_in.b (i) = "0"b;
 728                                    base_regs (i).type = 0;
 729                               end;
 730                     end;
 731           end;
 732 
 733           return;
 734 
 735 state_man$update_ref: entry (pt);
 736 
 737 /* this entry is called to add a reference to machine state */
 738 
 739           p = pt;
 740           if p -> reference.data_type <= real_flt_bin_2 then goto up_q;
 741 
 742           if p -> reference.data_type <= complex_flt_bin_2
 743           then do;
 744 
 745 /* update complex register */
 746 
 747                     q = complex_reg.variable;
 748                     if q ^= null then q -> reference.value_in.complex_aq = "0"b;
 749 
 750                     complex_reg.variable = p;
 751                     p -> reference.value_in.complex_aq = "1"b;
 752 
 753                     return;
 754                end;
 755 
 756           if p -> reference.long_ref
 757           then do;
 758 
 759 /* update string register */
 760 
 761                     q = string_reg.variable;
 762                     if q ^= null then q -> reference.value_in.string_aq = "0"b;
 763 
 764                     string_reg.variable = p;
 765                     string_reg.size = p -> reference.c_length;
 766                     p -> reference.value_in.string_aq = "1"b;
 767 
 768                     p -> reference.address_in.storage = "1"b;
 769 
 770                     return;
 771                end;
 772 
 773 /* update a register */
 774 
 775 up_a:     do i = 1 to a_reg.number;
 776                a_reg.variable (i) -> reference.value_in.a = "0"b;
 777           end;
 778 
 779           n = p -> reference.data_type;
 780           if n = bit_string | n = char_string
 781           then do;
 782                     a_reg.size = p -> reference.c_length * convert_size (n);
 783                     a_reg.offset = mod (convert_offset (p -> reference.units) * p -> reference.c_offset, bits_per_two_words);
 784                     if a_reg.offset + a_reg.size > bits_per_word then a_reg.length = bits_per_two_words;
 785                     else a_reg.length = bits_per_word;
 786                end;
 787           else a_reg.size, a_reg.offset = 0;
 788 
 789           a_reg.number = 1;
 790           a_reg.variable (1) = p;
 791           p -> reference.value_in.a = "1"b;
 792 
 793           return;
 794 
 795 /* update q register */
 796 
 797 up_q:     do i = 1 to q_reg.number;
 798                q_reg.variable (i) -> reference.value_in.q = "0"b;
 799           end;
 800 
 801           q_reg.number = 1;
 802           q_reg.variable (1) = p;
 803           p -> reference.value_in.q = "1"b;
 804 
 805           return;
 806 
 807 state_man$update_reg: entry (pt, which);
 808 
 809           dcl     (which, update)        bit (19) aligned;
 810 
 811           p = pt;
 812           update = which;
 813 
 814           if substr (update, 1, 1) then goto up_a;
 815           if substr (update, 2, 1) then goto up_q;
 816 
 817           return;
 818 
 819 state_man$erase_reg: entry (what);
 820 
 821 /* this entry is called to erase the contents of some register(s) */
 822 
 823           dcl     what                   bit (19) aligned;  /* what to erase */
 824 
 825           erase = what;
 826 
 827           if substr (erase, 1, 1)
 828           then do;
 829 
 830 /* if we are erasing a register, we have to check for
 831                   double fixed, floating point, or unpacked ptr
 832                   values left in "q" register */
 833 
 834                     if q_reg.number > 0
 835                     then do;
 836 
 837                               p = q_reg (1).variable;
 838                               n = p -> reference.data_type;
 839 
 840                               if n = real_fix_bin_2
 841                                    | n = real_flt_bin_1
 842                                    | n = real_flt_bin_2
 843                                    | n = unpacked_ptr
 844                               then
 845 
 846 /* have to erase q as well as a */
 847 
 848                                    substr (erase, 2, 1) = "1"b;
 849                          end;
 850 
 851                     call wipe;
 852                     return;
 853                end;
 854 
 855           if substr (erase, 2, 1)
 856           then do;
 857 
 858 /* if we are erasing q register, we have to check for
 859                   a string value that may have gotten shifted into q
 860                   register from a */
 861 
 862                     if a_reg.number ^= 0
 863                     then if a_reg.size + a_reg.offset > bits_per_word
 864                          then substr (erase, 1, 1) = "1"b;
 865                          else a_reg.length = min (a_reg.length, bits_per_word);
 866 
 867                end;
 868 
 869           call wipe;
 870           return;
 871 
 872 state_man$erase_temps: entry;
 873 
 874 /* This entry is called to save in storage any fixed binary temporary
 875              values with precision such that they could be loaded into index registers
 876              via eax instructions.  It is used to prevent sequence like
 877                     ldq       j
 878                     cmq       k
 879                     eax5      0,al
 880                     tsx0      ap|r_e_as
 881              from being generated                 */
 882 
 883           erase = "0"b;
 884 
 885           b19 = "1"b;
 886           do i = 1 to a_reg.number;
 887                p = a_reg (i).variable;
 888                if p -> reference.temp_ref then call check_temp;
 889           end;
 890 
 891           found = "0"b;
 892           do i = 1 to q_reg.number while (^found);
 893                p = q_reg (i).variable;
 894                n = p -> reference.data_type;
 895 
 896                if n = real_fix_bin_2 | n = real_flt_bin_2
 897                     | n = real_flt_bin_1 | n = unpacked_ptr
 898                then found = "1"b;
 899           end;
 900 
 901           if found
 902           then do;
 903                     b19 = "01"b;
 904                     do i = 1 to q_reg.number;
 905                          p = q_reg (i).variable;
 906                          if p -> reference.temp_ref then call check_temp;
 907                     end;
 908                end;
 909 
 910           if erase
 911           then do;
 912                     call wipe;
 913                     cg_stat$last_call = cg_stat$text_pos;   /* prevent xr_man from changing to eax  */
 914                end;
 915 
 916           return;
 917 
 918 state_man$unlock: entry;
 919 
 920 /* Unlocks all registers and updates used fields when necessary (for EIS) */
 921 
 922           a_reg.locked, q_reg.locked = "0"b;
 923           a_reg.number_h_o, q_reg.number_h_o = 0;
 924 
 925           text_pos = cg_stat$text_pos;
 926 
 927           do i = 0 to 7;
 928                if index_regs (i).type < 0
 929                then do;
 930                          if index_regs (i).variable ^= null
 931                          then index_regs (i).type = abs (index_regs (i).type);
 932                          else index_regs (i).type = 0;
 933                          index_regs (i).used = text_pos;
 934                     end;
 935           end;
 936 
 937           do i = 1 to 6;
 938                if base_regs (i).locked ^= 0
 939                then do;
 940                          base_regs (i).locked = 0;
 941                          base_regs (i).used = text_pos;
 942                     end;
 943           end;
 944 
 945           return;
 946 
 947 state_man$set_aliasables: entry (pt);
 948 
 949 /* When an aliasable variable (one that may have an alias) is set, all potential aliases must
 950    be removed from the machine state.  We only search for shared aliases because the optimizer
 951    and semantic_translator have automatically handled unshared aliases by the reference count
 952    scheme. */
 953 
 954           dcl     all                    bit (1) aligned;   /* "1"b if _^Ha_^Hl_^Hl aliasables are to be flushed */
 955 
 956           p = pt;
 957           all = p = null;
 958 
 959           if machine_state.indicators = -2
 960           then do;
 961                     q = indicators_ref (2);
 962                     if compare_aliasables ()
 963                     then machine_state.indicators = 0;
 964                     else do;
 965                               q = indicators_ref (3);
 966                               if compare_aliasables ()
 967                               then machine_state.indicators = 0;
 968                          end;
 969                end;
 970 
 971           n = a_reg.number;
 972           i = 1;
 973           do while (i <= n);
 974                q = a_reg.variable (i);
 975                if compare_aliasables ()
 976                then do;
 977                          q -> reference.value_in.a = "0"b;
 978                          n = n - 1;
 979                          do j = i to n;
 980                               a_reg.variable (j) = a_reg.variable (j + 1);
 981                          end;
 982                     end;
 983                else i = i + 1;
 984           end;
 985           a_reg.number = n;
 986 
 987           n = q_reg.number;
 988           i = 1;
 989           do while (i <= n);
 990                q = q_reg.variable (i);
 991                if compare_aliasables ()
 992                then do;
 993                          q -> reference.value_in.q = "0"b;
 994                          n = n - 1;
 995                          do j = i to n;
 996                               q_reg.variable (j) = q_reg.variable (j + 1);
 997                          end;
 998                     end;
 999                else i = i + 1;
1000           end;
1001           q_reg.number = n;
1002 
1003           q = string_reg.variable;
1004           if q ^= null
1005           then if compare_aliasables ()
1006                then do;
1007                          q -> reference.value_in.string_aq = "0"b;
1008                          string_reg.variable = null;
1009                     end;
1010 
1011           q = complex_reg.variable;
1012           if q ^= null
1013           then if compare_aliasables ()
1014                then do;
1015                          q -> reference.value_in.complex_aq = "0"b;
1016                          complex_reg.variable = null;
1017                     end;
1018 
1019           q = decimal_reg.variable;
1020           if q ^= null
1021           then if compare_aliasables ()
1022                then do;
1023                          q -> reference.value_in.decimal_aq = "0"b;
1024                          decimal_reg.variable = null;
1025                     end;
1026 
1027           do i = 0 to 7;
1028                if index_regs (i).type >= 2
1029                then do;
1030                          q = index_regs (i).variable;
1031                          if compare_aliasables ()
1032                          then do;
1033                                    q -> reference.value_in.x (i) = "0"b;
1034                                    index_regs (i).type = 0;
1035                               end;
1036                     end;
1037           end;
1038 
1039           do i = 1 to 6;
1040                if base_regs (i).type = 1
1041                then do;
1042                          q = base_regs (i).variable;
1043                          if compare_aliasables ()
1044                          then do;
1045                                    q -> reference.value_in.b (i) = "0"b;
1046                                    base_regs (i).type = 0;
1047                               end;
1048                     end;
1049           end;
1050 
1051           return;
1052 
1053 
1054 check_temp: proc;
1055 
1056           if p -> reference.data_type ^= real_fix_bin_1 then goto back;
1057           if p -> reference.value_in.storage then goto back;
1058           if p -> reference.ref_count < 1 then goto back;
1059           if p -> reference.symbol -> symbol.c_dcl_size < bits_per_half
1060           then erase = erase | b19;
1061 
1062 back: end;
1063 
1064 get_ms: proc;
1065 
1066           m_s_p = cg_stat$ms_list;
1067           if m_s_p ^= null then cg_stat$ms_list = machine_state.next;
1068           else do;
1069                     allocate machine_state in (xeq_tree_area) set (m_s_p);
1070                     m_s_p -> node.type = machine_state_node;
1071                     pl1_stat_$node_uses (bin (machine_state_node, 9)) = pl1_stat_$node_uses (bin (machine_state_node, 9)) + 1;
1072                end;
1073 
1074      end;
1075 
1076 compare_aliasables: proc () returns (bit aligned);
1077 
1078           if p ^= q
1079           then if q -> reference.shared
1080                then if all
1081                     then if q -> reference.aliasable
1082                          then return ("1"b);
1083                          else if q -> reference.symbol -> symbol.block_node ^= null
1084                          then return (q -> reference.symbol -> symbol.block_node -> block.flush_at_call);
1085                          else ;
1086                     else if q -> reference.aliasable
1087                     then return (compare_alias ((p -> reference.symbol), (q -> reference.symbol)));
1088 
1089           return ("0"b);
1090      end;
1091 
1092 %include compare_alias;
1093 
1094 
1095 wipe: proc;
1096 
1097           if substr (erase, 1, 1)
1098           then do;
1099 
1100                     do i = 1 to a_reg.number;
1101                          p = a_reg.variable (i);
1102                          call save_temp (1);
1103                          p -> reference.value_in.a = "0"b;
1104                     end;
1105 
1106                     a_reg.constant,
1107                          a_reg.number = 0;
1108                end;
1109 
1110           if substr (erase, 2, 1)
1111           then do;
1112 
1113                     do i = 1 to q_reg.number;
1114                          p = q_reg.variable (i);
1115                          call save_temp (2);
1116                          p -> reference.value_in.q = "0"b;
1117                     end;
1118 
1119                     q_reg.constant,
1120                          q_reg.number = 0;
1121                end;
1122 
1123           if substr (erase, 3, 1)
1124           then do;
1125                     p = string_reg.variable;
1126                     if p ^= null
1127                     then do;
1128                               call save_temp (3);
1129                               p -> reference.value_in.string_aq = "0"b;
1130                               string_reg.variable = null;
1131                          end;
1132                end;
1133 
1134           if substr (erase, 4, 1)
1135           then do;
1136                     q = complex_reg.variable;
1137                     if q ^= null
1138                     then do;
1139                               q -> reference.value_in.complex_aq = "0"b;
1140                               complex_reg.variable = null;
1141                          end;
1142                end;
1143 
1144           if substr (erase, 5, 1)
1145           then do;
1146                     q = decimal_reg.variable;
1147                     if q ^= null
1148                     then do;
1149                               q -> reference.value_in.decimal_aq = "0"b;
1150                               decimal_reg.variable = null;
1151                          end;
1152                end;
1153 
1154           do i = 0 to 7;
1155                if substr (erase, i + 6, 1)
1156                then do;
1157                          if index_regs (i).type >= 2
1158                          then do;
1159                                    p = index_regs (i).variable;
1160                                    if p ^= null
1161                                    then do;
1162                                              call save_temp (0);
1163                                              p -> reference.value_in.x (i) = "0"b;
1164                                         end;
1165                               end;
1166 
1167                          index_regs (i).type = 0;
1168                     end;
1169           end;
1170 
1171           do i = 1 to 6;
1172                if substr (erase, i + 13, 1)
1173                then do;
1174                          p = base_regs (i).variable;
1175                          n = base_regs (i).type;
1176                          if p = null then n = 0;
1177 
1178                          if n = 1
1179                          then do;
1180                                    p -> reference.value_in.b (i) = "0"b;
1181                                    call save_temp (-i);
1182                               end;
1183                          else if n = 2
1184                          then p -> reference.address_in.b (i) = "0"b;
1185 
1186                          base_regs (i).type = 0;
1187                     end;
1188           end;
1189 
1190 
1191      end;
1192 
1193 
1194 save_temp: proc (reg);
1195 
1196           dcl     reg                    fixed bin;
1197 
1198           dcl     ca                     ptr;
1199 
1200           dcl     (macro, t, k)          fixed bin (15);
1201 
1202           dcl     (stfx1                 init (15),
1203                   stfx2                  init (16),
1204                   save_string_aq         init (229),
1205                   sxl0                   init (345),
1206                   stx0                   init (714),
1207                   zero_mac               init (308),
1208                   store_base             (23:24, 6) init (61, 409, 622, 623, 624, 625, /* unpacked */
1209                                          630, 631, 632, 633, 634, 635), /* packed */
1210                   sta                    init (4)) fixed bin (15) int static;
1211 
1212           if cg_stat$m_s_p = null then return;
1213 
1214           if ^p -> reference.temp_ref then goto exit;
1215 
1216           if p -> reference.ref_count <= 0 then goto exit;
1217 
1218           if p -> reference.value_in.storage then goto exit;
1219 
1220           if p -> reference.symbol = null then goto exit;
1221 
1222           if p -> reference.dont_save then go to exit;
1223 
1224           if p -> reference.aggregate then go to exit;
1225 
1226           t = p -> reference.data_type;
1227 
1228           if reg = 2
1229           then do;
1230                     if t = unpacked_ptr
1231                     then if string (p -> reference.value_in.b)
1232                          then goto exit; else goto save;
1233 
1234                     if t = real_fix_bin_1
1235                     then if p -> reference.symbol -> symbol.c_dcl_size < bits_per_half
1236                          then if string (p -> reference.value_in.x)
1237                               then goto exit;
1238                end;
1239 
1240 save:     p -> reference.store_ins = bit (cg_stat$text_pos, 18);
1241           p -> reference.ref_count = p -> reference.ref_count + 1;
1242 
1243           if reg < 0
1244           then do;
1245                     macro = store_base (t, abs (reg));
1246                     goto gen;
1247                end;
1248 
1249           if reg = 3
1250           then do;
1251                     if p -> reference.allocated then go to exit;
1252                     if ^p -> reference.address_in.storage then go to exit;
1253 
1254                     call stack_temp$assign_block (p, 2);
1255 
1256 /* we must ensure that saving the string aq does
1257                        not alter any registers */
1258 
1259                     if string (p -> reference.address_in.b)
1260                     then do;
1261                               k = index (string (p -> reference.address_in.b), "1"b) - 1;
1262                               p -> reference.address_in.storage = "0"b;
1263                               call expmac ((store_base (23, k)), p);
1264                               p -> reference.address_in.storage = "1"b;
1265                          end;
1266                     else do;
1267                               ca = c_a (p -> reference.qualifier -> temporary.location, 4);
1268                               call expmac$one_eis ((save_string_aq), ca);
1269                               p -> reference.ref_count = p -> reference.ref_count - 1;
1270                          end;
1271 
1272                     go to exit;
1273                end;
1274 
1275           if reg = 1
1276           then do;
1277                     if t < char_string then k = 0;
1278                     else k = fixed (p -> reference.c_length * convert_size (t) > bits_per_word, 1);
1279                     call expmac$one ((sta), p, k);
1280 
1281                     if a_reg.offset ^= 0
1282                     then do;
1283                               p -> reference.aligned_ref = "0"b;
1284                               p -> reference.c_offset = a_reg.offset;
1285                               p -> reference.units = bit_;
1286                          end;
1287                end;
1288           else do;
1289                     if reg = 0
1290                     then do;
1291                               if p -> reference.symbol -> symbol.c_dcl_size < bits_per_half
1292                               then do;
1293                                         macro = stx0 + i;
1294 
1295 /* convert the value in index register to "packed"
1296                                  integer in storage */
1297 
1298                                         p -> reference.aligned_ref = "0"b;
1299                                         p -> reference.c_offset = 0;
1300                                         p -> reference.c_length = bits_per_half;
1301                                         p -> reference.units = word_;
1302 
1303 /* We set reference.dont_save as a
1304                                  kludge to fix bug 1599.  This
1305                                  prevents save_value from converting
1306                                  this back to an aligned temp,
1307                                  which could cause problems after
1308                                  an if statement. */
1309 
1310                                         p -> reference.dont_save = "1"b;
1311                                    end;
1312 
1313                               else do;
1314                                         macro = sxl0 + i;
1315                                         p -> reference.ref_count = p -> reference.ref_count + 1;
1316                                         call expmac ((zero_mac), p);
1317                                    end;
1318                          end;
1319                     else if t = unpacked_ptr | t = complex_flt_bin_1 then macro = stfx2;
1320                     else if t = packed_ptr | t = bit_string then macro = stfx1;
1321                     else macro = stfx1 - 1 + t;
1322 
1323 gen:                call expmac (macro, p);
1324                end;
1325 
1326           p -> reference.value_in.storage = "1"b;
1327 
1328 exit: end;
1329 
1330 need_ref: proc returns (bit (1) aligned);
1331 
1332           dcl     (p1, p2)               ptr;
1333 
1334           if ^optimize
1335           then return ("1"b);
1336 
1337           if p -> reference.temp_ref
1338           then do p1 = q repeat (p1 -> element (4)) while (p1 ^= null);
1339                     p2 = p1 -> element (1);
1340 
1341                     if p2 -> node.type = operator_node
1342                     then do;
1343                               if substr (p2 -> operator.op_code, 1, 5) = "00111"b /* mod_bit class */
1344                               then if p2 -> operand (2) = p
1345                                    then return ("1"b);
1346 
1347                               p2 = p2 -> operand (1);
1348                          end;
1349 
1350                     if p = p2 then return ("1"b);
1351                end;
1352 
1353           return ("0"b);
1354      end;
1355 
1356      end;