1 /* ***********************************************************
   2    *                                                         *
   3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   4    *                                                         *
   5    * Copyright (c) 1972 by Massachusetts Institute of        *
   6    * Technology and Honeywell Information Systems, Inc.      *
   7    *                                                         *
   8    *********************************************************** */
   9 
  10 
  11 /* Modified: 15 Feb 1978 by PCK to implement options(main) and the stop statement */
  12 /* Modified 790807 by PG to remove jump_three_way */
  13 
  14 optimizer: proc(root);
  15 
  16 dcl       root ptr;           /* points at root block node */
  17 dcl       (blk,stm,p,q) ptr;
  18 dcl       set_level fixed bin;
  19 dcl       (doing_loop,inhibit_walk,state_is_discarded) bit(1) aligned;
  20 dcl       statement_type bit(9) aligned;
  21 dcl       pl1_stat_$cur_statement ptr ext static;
  22 dcl       pl1_stat_$stop_id bit(27) ext static;
  23 dcl       (ioa_,ioa_$nnl) entry options(variable), debug entry();
  24 dcl       (s_list,p_list,free,freec,p_tail,freep,freep_tail,l_list) ptr int static;
  25 
  26 dcl       n fixed bin(15);
  27 
  28 dcl       1 primary           based aligned,
  29           2 node_type         bit(9) unaligned,
  30           2 reserved          bit(12) unaligned,
  31           2 number            fixed binary(14) unaligned,
  32           2 computation       ptr unaligned,
  33           2 statement         ptr unaligned,
  34           2 last              ptr unaligned,
  35           2 next              ptr unaligned;
  36 
  37 dcl       1 secondary         based aligned,
  38           2 node_type         bit(9) unaligned,
  39           2 reserved          bit(12) unaligned,
  40           2 number            fixed binary(14) unaligned,
  41           2 operation         ptr unaligned,
  42           2 primary           ptr unaligned,
  43           2 last              ptr unaligned,
  44           2 next              ptr unaligned;
  45 
  46 dcl       1 chain             based aligned,
  47           2 node_type         bit(9) unaligned,
  48           2 reserved          bit(12) unaligned,
  49           2 number            fixed binary(14) unaligned,
  50           2 value             ptr unaligned,
  51           2 next              ptr unaligned initial(null);
  52 
  53 dcl       (null,string,substr) builtin;
  54 
  55 %include language_utility;
  56 %include block;
  57 %include statement;
  58 %include operator;
  59 %include symbol;
  60 %include boundary;
  61 %include label;
  62 %include list;
  63 %include reference;
  64 %include op_codes;
  65 %include statement_types;
  66 %include nodes;
  67 
  68 begin:
  69           inhibit_walk = "0"b;
  70           set_level = 0;
  71           s_list,p_list,free,freec,p_tail,freep,freep_tail,l_list=null;
  72           blk=root->block.son;
  73 scan:
  74           do while(blk->block.son ^= null);
  75           blk=blk->block.son;
  76           end;
  77 statements:
  78           doing_loop = "0"b;
  79           do stm = blk->block.prologue, blk->block.main;
  80           state_is_discarded = "0"b;
  81           do stm = stm repeat stm->statement.next while(stm^=null);
  82           pl1_stat_$cur_statement = stm;
  83           if string(stm -> statement.source_id) = string(pl1_stat_$stop_id)
  84           then do;
  85                     call ioa_$nnl("optimizer at ^p: ^a^/DB ",stm,decode_node_id(stm,"0"b));
  86                     call debug;
  87                end;
  88           statement_type = stm->statement.statement_type;
  89           if statement_type = entry_statement
  90                then do;
  91                     call clear;
  92                     state_is_discarded = "0"b;
  93                     end;
  94                else if statement_type ^= procedure_statement
  95                     then if statement_type ^= format_statement
  96                     then do;
  97                          if stm->statement.labels ^= null
  98                          then do;
  99                               call intersection(stm,1);     /* order of calls is crucial */
 100                               call intersection(stm,2);     /* leave proper info on prim's for cg
 101                                                                or create new state */
 102                               end;
 103                          if ^ state_is_discarded
 104                               then call reduce(stm->statement.root,stm,"0"b,"0"b);
 105                          if statement_type = return_statement | statement_type = stop_statement
 106                          then state_is_discarded = "1"b;
 107                          else if statement_type = begin_statement
 108                               then call erase;
 109                          end;
 110           end;
 111           end;
 112           call clear;
 113 
 114 /* process the list of loop operators */
 115 
 116           p = l_list;
 117           do while(p ^= null);
 118                doing_loop = "1"b;
 119                q = p -> chain.value;
 120                call reduce(q->operand(1),q,"0"b,"0"b);
 121                call clear;
 122                if p -> chain.next = null
 123                then do;
 124                     p -> chain.next = freec;
 125                     freec = l_list;
 126                     l_list = null;
 127                     go to next_block;
 128                     end;
 129                p = p -> chain.next;
 130                end;
 131 
 132 /* set blk to point to the next block node. */
 133 
 134 next_block:
 135           if blk->block.brother ^= null
 136                     then blk=blk->block.brother;
 137                     else if blk->block.father ^= null
 138                               then do;
 139                                         blk=blk->block.father;
 140                                         go to statements;
 141                                    end;
 142                               else return;
 143           go to scan;
 144 
 145 
 146 /* this routine walks down the tree matching all computations against the primary list,
 147 and entering all reducible computations into the primary list if they are not already
 148 there.  If an operator or reference node matches a computation in the primary list,
 149 the parent node is modified to refer to the node that is in the primary list, and the
 150 reference count of that node is increased by one.  The reference count, if any,
 151 in the matching node is decreased by one and ,if possible, the node is freed.
 152 All operators which could alter the value of a variable are recognized
 153 and any computation which depends on these variables is removed from the primary list.  */
 154 
 155 /* inhibit is an input parameter used to prevent commoning or entry onto the
 156    primary list of any node contained in a loop subtree.
 157 
 158    irreducible is an output parameter set when an operator node is found to be
 159    irreducible.  An operator is irreducible if it:
 160 
 161           1. is a call to an irreducible entry.
 162           2. produces side effects or output that depends on something
 163              other than its formal input.
 164           3. contains any of the above.
 165 
 166 irreducible_op is a local variable used to determine if a given node is an irreducible
 167 operator.  If it is irreducible it is not put on the primary list, but contained
 168 subexpression may be put on the list if they are not themselves irreducible.
 169 
 170 The top operaotor of an argument subexpression is never commoned
 171 or put on the primary list, but it is not considered irreducible in the
 172 sense that it does not make its containing operator irreducible.  This
 173 is because if the containing operator is a reducible function the
 174 programmer has declared that the function won't alter its argument.  If
 175 the containing operator is an irreducible function, we don't need to
 176 pass back this information.  Since at the level where
 177 we process the argument, we don't know wheither or not the containing
 178 function is reducible, we don't set the irreducible bit for the
 179 top operator of an argument.
 180 
 181 Before the code_generator phase, reference.inhibit = "1"b means that the reference
 182 is the base of a defined variable (used for its address not its value) and should
 183 not be commoned.  This prevents conversion of the reference to a temporary by the
 184 code generator, which would destroy the address.
 185 
 186 Note that a given invocation of reduce cannot return unless it is at the bottom of the tree
 187 or has just called erase or has been commoned.  This insures that all set contexts
 188 are scanned.  A commoned subtree cannot contain a set context because if it did, it
 189 would be irreducible and therefore not in the primary list.  */
 190 
 191 reduce: proc(pt,parent,irreducible,inhibit);
 192 
 193 dcl       pt ptr unaligned;
 194 dcl       (parent,p,q,p1,p2,p3,s1,tp) ptr;
 195 dcl       (i,j)fixed bin(15);
 196 dcl       opcode bit(9) aligned;
 197 dcl       (irreducible,sets_operand1,inhibit,signal_op,new_primary,
 198           irreducible_op,jump_op,irreducible_entry,addr_op,
 199           sets_reference,irreducible_sons,inhibit_sons,irreducible_2)
 200           bit(1) aligned;
 201 
 202 
 203 begin:
 204           p = pt;
 205           if p=null then return;
 206           if p->node.type = reference_node
 207                     then do;
 208                               p1 = p->reference.symbol;
 209                               if p1->node.type = symbol_node
 210                                    then do;
 211 
 212                                         /* The aliasable bit of a reference node means that the storage
 213                                            identified by this reference is potentially accessable via
 214                                            another name, this is a potential alias.  The circumstances
 215                                            that cause the aliasable bit of the symbol node to be set are:
 216 
 217                                                   The variable is used as an argument to addr.
 218                                                   (note that put string(x), read into(x),  read or locate set(x)
 219                                                   all take addr of x.)
 220                                                   The variable is the base of a defined variable.
 221                                                   The variable is defined.
 222                                                   The variable is based.
 223                                                   The variable is external.
 224                                                   The variable is a parameter.
 225                                                   The variable is passed as an argument by_reference and is static or controlled.
 226 
 227                                         The reference is aliasable (potentially aliased) if its symbol node
 228                                         has the aliasable bit or if it is a reference to a nonlocal automatic
 229                                         variable that is passed as an argument by_reference.  */
 230 
 231                                         p->reference.aliasable = p1->symbol.aliasable|
 232                                                   (p1->symbol.auto&(blk^=p1->symbol.block_node)&p1->symbol.passed_as_arg);
 233 
 234                                         /* this code is executed to exclude from optimization those simple references
 235                                            that are done by the code generator.  If they were included here,
 236                                            the size of the tree would be very large.  */
 237 
 238                                         if p->reference.offset=null
 239                                              then if p->reference.qualifier=null
 240                                                   then if p->reference.length=null
 241                                                        then if p1->symbol.temporary
 242                                                             then return;
 243                                                             else if p->reference.units=word_ | p->reference.units=0
 244                                                                  then if p -> reference.ref_count = 0
 245                                                                       then if ^ (p1->symbol.packed & p1->symbol.member)
 246                                                                            then if p = p1 -> symbol.reference
 247                                                                                 then return;
 248                                                                                 else do;
 249                                                                                      p2 = p1 -> symbol.reference;
 250                                                                                      if compare_expression(p,p2)
 251                                                                                           then pt = p2;
 252                                                                                      return;
 253                                                                                      end;
 254                                         end;
 255 
 256 /* search the primary list for a previously computed instance of this reference.  */
 257 
 258                               q = p_list;
 259                               if ^inhibit
 260                               then if ^ p->reference.inhibit
 261                               then do;
 262                               do while(q^=null);
 263                               p2 = q -> primary.computation;
 264                               if p = p2
 265                                  then return;
 266                                  else if compare_expression(p2,p)
 267                                    then do;
 268 
 269 /* replace this reference with the previously computed one.  */
 270 
 271                                         pt = p2;
 272                                         p2->reference.ref_count = p2->reference.ref_count+1;
 273                                         call adjust_count(p);
 274                                         return;
 275                                         end;
 276                               q = q->primary.next;
 277                               end;
 278                               end;
 279 
 280 /* determine the reducibility of this reference while reducing its sons.  */
 281 
 282                               irreducible_op = "0"b;
 283                               if ^ inhibit_walk
 284                               then if ^p->reference.shared            /* shared references have no sons */
 285                                    then do;
 286                                         call reduce_ref_sons(p,irreducible_op);
 287                                         end;
 288                               irreducible = irreducible|irreducible_op;
 289                               if inhibit|irreducible_op|p->reference.inhibit then return;
 290 
 291 /* no temporaries can go on the primary list */
 292 
 293                               if p1 -> node.type = symbol_node
 294                               then if p1 -> symbol.temporary
 295                                    then return;
 296 
 297 /* only unshared references should go on the primary list */
 298 
 299                               if p -> reference.shared
 300                               then do;
 301                                    p = copy_expression((p));
 302                                    p -> reference.shared = "0"b;
 303                                    p -> reference.ref_count = 1;
 304                                    pt = p;
 305                                    end;
 306 
 307 /* put this reference on the primary list.  */
 308 
 309                               q = create_node(p_list,1);
 310                               q->primary.computation = p;
 311                               q->primary.statement = pl1_stat_$cur_statement;
 312                               call record_secondaries(p,1);
 313                               return;
 314                          end;
 315           if p->node.type = list_node
 316                     then do;
 317                               do i = 1 to p->list.number;
 318                               call reduce(p->list.element(i),p,irreducible,inhibit);
 319                               end;
 320                               return;
 321                          end;
 322           if p->node.type ^= operator_node then return;
 323 
 324 /* join operators should be handled like list nodes except that they are always irreducible */
 325 
 326           opcode = p->operator.op_code;
 327 
 328           if opcode = join
 329                     then do;
 330                               do i = 1 to p->operator.number;
 331                               call reduce(p->operator.operand(i),p,irreducible,inhibit);
 332                               end;
 333                               irreducible = "1"b;
 334                               return;
 335                          end;
 336 
 337 /* classify this operator and determine if it is irreducible.  */
 338 
 339           jump_op = opcode>=jump & opcode<=jump_if_ge;
 340           signal_op = opcode=record_io|opcode=allot_ctl|opcode=signal_on|opcode=terminate_trans|opcode=stream_prep|
 341                     opcode=open_file|opcode=close_file|opcode=allot_based|(opcode>=get_list_trans & opcode<=put_data_trans)|
 342                     opcode=lock_fun|opcode=stacq_fun;
 343           irreducible_op = signal_op|jump_op|p->operator.number=0|opcode=return_words|
 344                     (opcode>=return_bits & opcode<=allot_auto)|opcode=free_ctl|
 345                     (opcode>=empty_area & opcode<=vclock_fun)|(opcode>=loop & opcode<=nop);
 346           sets_operand1 = ^(opcode=return_words|opcode=return_bits|opcode=return_string|opcode=std_entry|
 347                     jump_op|p->operator.number=0|(opcode>=loop & opcode<=nop));
 348           addr_op = opcode = addr_fun | opcode = addr_fun_bits;
 349 
 350           if addr_op
 351                then addr_op = p -> operand(2) -> node.type = reference_node;
 352 
 353           irreducible = irreducible|irreducible_op;
 354 
 355 
 356 /* search the primary list for a previously computed instance of this operator.
 357    If one is found, make the parent of this node point to it. */
 358 
 359 
 360           q=p_list;
 361           if ^(inhibit|irreducible_op|parent->node.type = list_node)
 362           then do;
 363           do while(q^=null);
 364           p2 = q -> primary.computation;
 365           if p = p2
 366                then return;
 367                else if compare_expression(p2,p)
 368                     then do;
 369                               p1 = p2->operand(1);
 370                               if p1->reference.shared
 371                                         then do;
 372                                                   p1,p2->operand(1) = copy_expression((p1));
 373                                                   p1->reference.shared = "0"b;
 374                                                   p1->reference.ref_count = 1;
 375                                              end;
 376                               pt = p2;
 377                               p1->reference.ref_count = p1->reference.ref_count+1;
 378                               call adjust_count(p);
 379                               return;
 380                          end;
 381           q=q->primary.next;
 382           end;
 383           end;
 384 
 385 /* If the operator can produce a signal that is allowed to alter storage and return,
 386    process it as if it was a call to an external entry.  */
 387 
 388           if signal_op
 389                then do;
 390                     irreducible_sons = "0"b;
 391 
 392                     if opcode = get_data_trans
 393                          then do;
 394                               if p->operand(1) = null
 395                                    then call erase;                   /* this is get data;  */
 396                                    else do;
 397                                         p = p->operand(1);            /* join operator */
 398                                         do i = 1 to p->operator.number;
 399                                         call set((p->operand(i)));
 400                                         end;
 401                                         end;
 402                               call external_call;
 403                               return;
 404                               end;
 405 
 406                     if opcode = get_edit_trans | opcode = get_list_trans
 407                          then do;
 408                               call reduce(p->operand(1),p,irreducible_op,inhibit);
 409                               q = p->operand(2);
 410                               if ^ q -> reference.shared
 411                                    then call reduce_ref_sons(q,irreducible_sons);
 412                               call set(q);
 413                               call external_call;
 414                               call check_and_reduce_target(2 /* ,q,p,irreducible_sons */);
 415                               return;
 416                               end;
 417 
 418                     if opcode = allot_ctl
 419                          then do;
 420                               call reduce(p -> operand(2),p,irreducible_op,inhibit);
 421                               call set((p->operand(1)));
 422                               call external_call;
 423                               call reduce(p->operand(1),p,irreducible_op,inhibit);
 424                               return;
 425                               end;
 426 
 427                     if opcode = allot_based
 428                     then do;
 429                          q = p -> operand(1);
 430 
 431                          /* set option evaluated first and only once */
 432 
 433                          if ^ q -> reference.shared
 434                               then call reduce_ref_sons(q,irreducible_sons);
 435 
 436                          /* operations after this point may be retried */
 437 
 438                          call external_call;
 439 
 440                          call reduce(p -> operand(2),p,irreducible_op,inhibit);
 441 
 442                          if p -> operand(3) ^= null
 443                          then do;
 444                               call reduce(p -> operand(3),p,irreducible_op,inhibit);
 445                               call set((p -> operand(3)));
 446                               end;
 447 
 448                          call set(q);
 449                          call external_call;
 450                          call check_and_reduce_target(1 /* ,q,p,irreducible_sons */);
 451                          return;
 452                          end;
 453 
 454                     if opcode = lock_fun | opcode = stacq_fun
 455                     then do;
 456                          do i = 2 to p->operator.number;
 457                               call reduce(p->operand(i),p,irreducible_op,inhibit);
 458                               end;
 459 
 460                          q = p -> operand(1);
 461                          if ^ q -> reference.shared
 462                               then call reduce_ref_sons(q,irreducible_sons);
 463 
 464                          if opcode = stacq_fun
 465                               then call set((p -> operand(2)));
 466                               else call external_call;
 467                          call set(q);
 468 
 469                          call check_and_reduce_target(1 /* ,q,p,irreducible_sons */);
 470                          return;
 471                          end;
 472 
 473                     do i = 1 to p->operator.number;
 474                     call reduce(p->operand(i),p,irreducible_op,inhibit);
 475                     end;
 476                     call external_call;
 477                     return;
 478                     end;
 479 
 480 /* all operators processed after this point do not produce conditions of interest to the optimizer.  */
 481 
 482           if opcode = free_based
 483           then do;
 484                call reduce(p -> operand(2),p,irreducible_op,inhibit);
 485                call reduce_ref_sons((p -> operand(1)),irreducible_op);
 486 
 487                if p -> operand(3) ^= null
 488                then do;
 489                     call reduce(p -> operand(3),p,irreducible_op,inhibit);
 490                     call set((p -> operand(3)));
 491                     end;
 492 
 493                /* last block of code here is nonstandard and corresponds to runtime action */
 494 
 495                if p -> operand(1) -> reference.qualifier -> node.type = reference_node
 496                     then call set((p -> operand(1) -> reference.qualifier));
 497 
 498                return;
 499                end;
 500 
 501           if opcode = fortran_read
 502                then do;
 503                     do i = 1 to 9;
 504                     call reduce(p->operand(i),p,irreducible_op,inhibit);
 505                     end;
 506                     p1 = p->operand(10);
 507                     if p1 ^= null                 /* check for an I/O list */
 508                          then do i = 1 to p1->list.number;
 509                               call set((p1->list.element(i)));
 510                               call reduce(p1->operand(i),p1,irreducible_op,inhibit);
 511                               end;
 512                     return;
 513                     end;
 514 
 515 /* reduce the second operand of all non-addr_op operators that have at least two operands.
 516   (we omit reduction of the second operand of addr_ops to avoid code optimizations
 517    for short strings done by the code generator) */
 518 
 519           if p->operator.number >= 2
 520           then if ^ addr_op
 521                then do;
 522                     irreducible_2 = "0"b;
 523                     call reduce(p -> operand(2),p,irreducible_2,inhibit);
 524                     irreducible_op = irreducible_op | irreducible_2;
 525                     end;
 526                else do;
 527                     tp = p -> operand(2);
 528                     tp->reference.aliasable = tp->reference.symbol->symbol.aliasable;
 529                     if ^ tp -> reference.shared
 530                          then call reduce_ref_sons(tp,irreducible_op);
 531                     end;
 532 
 533           if opcode = std_call
 534           then do;
 535 
 536 /* Calls to internal procedures and entry variables may set anything.  Calls to external
 537    entries can set: arguments passed by reference, aliased variables, and variables declared in a flush_at_call block.
 538    The flush_at_call bit indicates that this block contains an on-unit, or an
 539    internal procedure whose name is assigned or passed as an argument.  Therefore,
 540    any call out from this block could result in the invocation of the on-unit or
 541    internal procedure and could set any variable known to this block.  */
 542 
 543 /* The operands of a std_call operator are processed somewhat differently than the
 544    operands of other operators.  We want to reduce the arguments of the call before
 545    flushing the primary list, but we do not want to actually reduce a reference
 546    node being passed as an argument until after the primary list is cleared
 547    (because of some code optimizations done by the code generator).  The solution
 548    we adopt is to reduce any length, qualifier, or offset expression on
 549    a reference before clearing primary list and to not reduce the reference at
 550    all. */
 551 
 552 /* the top operator of an argument expression passed to an irreducible entry cannot
 553 be commoned because it is usable as a variable in the called procedure.  */
 554 
 555                p3 = p->operand(2);
 556                if p3->node.type = reference_node
 557                     then irreducible_entry = p3->reference.symbol->symbol.irreducible;
 558                     else irreducible_entry = "1"b;
 559 
 560                irreducible_op = irreducible_op|irreducible_entry;
 561                if irreducible_entry
 562                then do;
 563                     p3 = p -> operand(3);
 564                     if p3 ^= null
 565                     then do;
 566                          q = p3 -> operand(2);
 567 
 568                          do i = 1 to q -> list.number;
 569                               tp = q -> element(i);
 570                               if tp -> node.type ^= reference_node
 571                               then call reduce(q -> element(i),q,irreducible_op,inhibit);
 572                               else do;
 573                                    if ^ tp -> reference.shared
 574                                         then call reduce_ref_sons(tp,irreducible_op);
 575                                    end;
 576                               end;
 577                          end;
 578 
 579                     q = p -> operand(2);
 580                     if q -> node.type = operator_node then q = q -> operand(1);
 581                     q = q -> reference.symbol;
 582 
 583                     if q -> symbol.variable | q -> symbol.internal | q->symbol.temporary
 584                     then do;
 585                          call erase;
 586                          end;
 587                     else do;
 588                          if p3 ^= null
 589                          then do;
 590                               q = p3 -> operand(2);
 591 
 592                               do i = 1 to q -> list.number;
 593                                    tp = q->list.element(i);
 594                                    if tp->node.type = reference_node
 595                                         then call set(tp);
 596                                    end;
 597 
 598                               end;
 599                          call external_call;
 600                          end;
 601 
 602                     end;
 603 
 604                else do;
 605                     p3 = p -> operand(3);
 606                     if p3 ^= null
 607                          then call reduce(p3 -> operand(2),p3,irreducible_op,inhibit);
 608                     end;
 609 
 610                end;
 611 
 612 /* reduce operands 3 through n for all operators that have them, except std_call.  */
 613 
 614           if opcode ^= std_call
 615                then do i = 3 to p->operator.number;
 616                     call reduce(p->operand(i),p,irreducible_op,inhibit);
 617                     end;
 618 
 619 
 620 
 621 /* If this operator is reducible and stores its output into operand1, put it on the primary list. */
 622 
 623           inhibit_sons = inhibit;
 624           sets_reference,
 625           irreducible_sons,
 626           new_primary = "0"b;
 627           if sets_operand1
 628                then if p->operator.operand(1) ^= null
 629                     then if p->operator.operand(1)->node.type = reference_node
 630                          then do;
 631 
 632                               /* we must reduce descendents of operand(1) before it is set */
 633 
 634                               sets_reference = "1"b;
 635                               q = p->operand(1);
 636                               if ^ q->reference.shared
 637                               then do;
 638                                    call reduce_ref_sons(q,irreducible_sons);
 639                                    inhibit_sons = inhibit_sons | irreducible_sons;
 640                                    irreducible_op = irreducible_op | irreducible_sons;
 641                                    end;
 642 
 643                               if ^(irreducible_op | inhibit | parent->node.type = list_node)
 644                               then do;
 645                                         new_primary = "1"b;
 646                                         p1=create_node(p_list,1);
 647                                         p1->primary.computation = p;
 648                                         p1->primary.statement = pl1_stat_$cur_statement;
 649                                         call record_secondaries(p,2); /* record all but operand 1 as secondaries. */
 650                                         if ^ q->reference.shared
 651                                              then call record_secondaries(q,0); /* record descendents of opnd1
 652                                                                                    as secondaries */
 653                                    end;
 654                               end;
 655 
 656 /* If the operator places its output into a variable the variable must be processed
 657    by the "set" routine to purge the primary list of any computation that depends on
 658   the value of this variable.  NOTE:  we must set the reference's aliasable bit
 659   here, because it may not yet have been reduced */
 660 
 661           if sets_reference
 662                then do;
 663                     if q->reference.symbol->node.type = symbol_node
 664                     then if ^(q->reference.symbol->symbol.temporary
 665                               |q->reference.symbol->symbol.return_value)
 666                               then do;
 667                                    s1 = q -> reference.symbol;
 668                                    q -> reference.aliasable = s1 -> symbol.aliasable |
 669                                         (s1->symbol.auto&(blk^=s1->symbol.block_node)&s1->symbol.passed_as_arg);
 670 
 671                                    call set(q);
 672 
 673                                    if ^ q->reference.shared
 674                                    then if ^ inhibit_sons
 675                                         then inhibit_sons = inhibit_sons | sons_were_set(q);
 676                                    end;
 677                     end;
 678 
 679 
 680 
 681 /* if this operator was entered on the primary list, record operand 1 as a secondary.
 682    This strange order is necessary to insure that i=i+1 is not retained as a primary,
 683    but a=b+c is retained.  Futhermore, a=b+c;a=10; must flush the add operator.  */
 684 
 685           if new_primary
 686                then if p_list ^= null
 687                     then if p_list->primary.computation = p
 688                                    then if ^p->operand(1)->reference.symbol->symbol.temporary
 689                                         then call record_secondaries((p->operand(1)),-1);
 690 
 691 /* reduce operand one of all operators. */
 692 
 693           inhibit_walk = sets_reference;
 694           inhibit_sons = inhibit_sons|(opcode=loop|opcode=ftn_trans_loop);
 695           if p->operator.number>0
 696                then if p->operator.operand(1) ^= null
 697                     then call reduce(p->operand(1),p,irreducible_op,inhibit_sons);
 698 
 699           irreducible = irreducible|irreducible_op;
 700           inhibit_walk = "0"b;
 701 
 702 /* If the operator is a loop operator which does not immediately contain another
 703 loop operator, and we are not processing the inside of a loop now, then put this
 704 operator on the loop chain.  */
 705 
 706           if opcode = loop
 707           then if ^ doing_loop
 708           then if p -> operand(1) -> operator.op_code ^= loop
 709           then do;
 710                     if freec = null
 711                     then do;
 712                          freec = create_list(2);
 713                          freec -> list.element(2) = null;
 714                          end;
 715                     p1 = freec;
 716                     freec = p1 -> chain.next;
 717                     p1 -> chain.next = l_list;
 718                     l_list = p1;
 719                     p1 -> chain.value = p;
 720                end;
 721 
 722 /* if the operator is a transfer check to see if it goes to a statement futher down in
 723 this block.  If it does, then attach the current p_list to the statement by taking the intersection
 724 of the list already on the statement and the current p_list.  Each time a transfer is processed the
 725 reference count in the statement node is decreased by one.  When the optimizer encounters the
 726 labeled statement it will check to see if all references have been processed by checking
 727 for a reference count of one.  If all references have been processed it will continue its optimization
 728 using the intersection of its current p_list and the list attached to the statement.  If all
 729 references have not been processed it will erase its p_list.   If the operator is an
 730 unconditional transfer mark the state as discarded.   */
 731 
 732           if jump_op
 733           then do;
 734                     q=p->operand(1);
 735                     if q -> node.type = label_node
 736                     then do;
 737                          if q -> label.block_node = blk
 738                               then call process_jump_target((q -> label.statement));
 739                          end;
 740                     else if q -> node.type = reference_node
 741                          then do;
 742                               s1 = q -> reference.symbol;
 743                               if s1 -> node.type = label_node
 744                               then if s1 -> label.block_node = blk
 745                               then if q -> reference.offset = null
 746                                    then call process_jump_target((s1->label.statement->element(q->reference.c_offset + 1)));
 747                                    else do;
 748                                         q = s1 -> label.statement;
 749                                         do j = 1 to q -> list.number;
 750                                              if q -> element(j) ^= null
 751                                                   then call process_jump_target((q -> element(j)));
 752                                              end;
 753                                         end;
 754                               end;
 755 
 756                     if opcode = jump
 757                          then state_is_discarded = "1"b;
 758 
 759                     /* set bit for cg's use in optimizing if statements */
 760 
 761                     if irreducible_2
 762                     then if p -> operator.number = 2        /* jump_true | jump_false */
 763                          then stm -> statement.irreducible = "1"b;
 764                end;
 765           return;
 766 
 767 
 768 reduce_ref_sons:    proc(pt,irreducible_sons);
 769 
 770 dcl       (p,pt) ptr;
 771 dcl       irreducible_sons bit(1) aligned;
 772 
 773           p = pt;
 774           if p -> reference.length ^= null
 775                then call reduce(p -> reference.length,p,irreducible_sons,inhibit);
 776           if p -> reference.qualifier ^= null
 777                then call reduce(p -> reference.qualifier,p,irreducible_sons,inhibit);
 778           if p -> reference.offset ^= null
 779                then call reduce(p -> reference.offset,p,irreducible_sons,inhibit);
 780 
 781           end; /* reduce_ref_sons */
 782 
 783 
 784 /* this routine searches the primary list for sons of operand(1) of an operator
 785    to see if they were set when operand(1) was set.  if so, operand(1) should
 786    not be put on the primary list */
 787 
 788 sons_were_set:      proc(pt) reducible returns(bit(1) aligned);
 789 
 790 dcl       (p,pt) ptr;
 791 
 792           p = pt;
 793 
 794           if ^ check((p->reference.qualifier))
 795           then if ^ check((p->reference.offset))
 796                then if ^ check((p->reference.length))
 797                     then return("0"b);
 798 
 799           return("1"b);
 800 
 801 check:    proc(pt) reducible returns(bit(1) aligned);
 802 
 803 dcl       (p,pt,q) ptr;
 804 
 805           p = pt;
 806 
 807           if p = null then go to ok;
 808           if p -> node.type = reference_node
 809           then if p -> reference.shared
 810                then go to ok;
 811 
 812           do q = p_list repeat q -> primary.next while(q ^= null);
 813                if q -> primary.computation = p then go to ok;
 814                end;
 815 
 816           return("1"b);
 817 ok:       return("0"b);
 818 
 819           end; /* check */
 820 
 821           end; /* sons_were_set */
 822 
 823 
 824 /* this routine, called for a signal_op, checks to see if a target can
 825    be reduced after the operation has taken place */
 826 
 827 check_and_reduce_target:      proc(i /* ,q,p,irreducible_sons */);
 828 
 829 dcl       i fixed bin;
 830 
 831           if ^ q -> reference.shared
 832           then if ^ irreducible_sons
 833                then irreducible_sons = irreducible_sons | sons_were_set(q);
 834 
 835           if ^ irreducible_sons
 836           then do;
 837                inhibit_walk = "1"b;
 838                call reduce(p -> operand(i),p,irreducible_op,inhibit);
 839                inhibit_walk = "0"b;
 840                end;
 841 
 842           end; /* check_and_reduce_target */
 843 
 844 
 845 /* this routine does the actual processing for targets of  jump_op's */
 846 
 847 process_jump_target: proc(pt);
 848 
 849 dcl       (pt,p1,p2,p4,q) ptr;
 850 
 851           p1 = pt;
 852 
 853           if p1->statement.ref_count_copy = 0
 854                then p1->statement.ref_count_copy=p1->statement.reference_count-1;
 855                else p1->statement.ref_count_copy=p1->statement.ref_count_copy-1;
 856           if string(p1->statement.source_id) < string(pl1_stat_$cur_statement->statement.source_id)
 857                     then return;
 858           if p1->statement.optimized
 859                     then call intersection(p1,2);
 860                     else do;
 861                               p1->statement.optimized="1"b;
 862                               q=p_list;
 863                               do while(q^=null);
 864                               p4=p1->statement.reference_list;
 865                               p2=create_node(p4,0);
 866                               p1->statement.reference_list=p4;
 867                               p2->primary.computation=q->primary.computation;
 868                               p2->primary.statement=q->primary.statement;
 869                               q=q->primary.next;
 870                               end;
 871                          end;
 872 
 873           end; /* process_jump_target */
 874 
 875           end; /* reduce */
 876 
 877 
 878 /* this routine walks down a tree recognizing references to variables
 879 and enters them in the secondary list if they are not already in the list.  */
 880 
 881 record_secondaries: proc(pt,start);
 882 
 883 dcl       (p,pt,q,p1,p2) ptr;
 884 dcl       (i,start) fixed bin(15);
 885 
 886           /* start :
 887                     -1        record pt but not its descendents
 888                     0         record pt's descendent but not pt
 889                     1         record pt and its descendents
 890                     2         record operands 2-n of operator pt */
 891 
 892 begin:
 893           p = pt;
 894           if p=null then return;
 895           if p->node.type = list_node
 896                     then do;
 897                               do i = 1 to p->list.number;
 898                               call record_secondaries((p->list.element(i)),1);
 899                               end;
 900                               return;
 901                          end;
 902           if p->node.type = operator_node
 903                     then do;
 904                               do i=start to p->operator.number;
 905                               call record_secondaries((p->operand(i)),1);
 906                               end;
 907                               return;
 908                          end;
 909 
 910           if p->node.type ^= reference_node then return;
 911 
 912           p1 = p->reference.symbol;
 913           if p1 ->node.type ^= symbol_node then return;
 914 
 915           if start >= 0
 916           then do;
 917                if p->reference.qualifier ^= null then call record_secondaries((p->reference.qualifier),1);
 918                if p->reference.offset ^= null then call record_secondaries((p->reference.offset),1);
 919                if p->reference.length ^= null then call record_secondaries((p->reference.length),1);
 920                end;
 921 
 922           if start = 0 then return;
 923 
 924           if p1 -> symbol.constant | p1 -> symbol.temporary then return;
 925 
 926 /* search the secondary list to see if the variable is in the list */
 927 
 928           q=s_list;
 929           do while(q^=null);
 930                p2 = q->secondary.operation;
 931                if p2 = p then goto chain_it;
 932                if p->reference.symbol = p2->reference.symbol
 933                then if compare_expression(p2,p)
 934                     then go to chain_it;
 935                q=q->secondary.next;
 936                end;
 937 
 938 /* make a new secondary entry for the variable              */
 939 
 940           q=create_node(s_list,2);
 941           q->secondary.primary=null;
 942           q->secondary.operation=p;
 943 
 944 
 945 /* add this primary to the list of primaries effected by this secondary */
 946 
 947 chain_it:
 948           if freec = null
 949                     then do;
 950                               freec = create_list(2);
 951                               freec->list.element(2) = null;
 952                          end;
 953           p1=freec;
 954           freec=p1->chain.next;
 955           p1->chain.next=q->secondary.primary;
 956           q->secondary.primary=p1;
 957           p1->chain.value=p_list;
 958           end record_secondaries;
 959 
 960 /* this routine removes entries from the secondary list and related
 961 primary list.                                                         */
 962 
 963 set: proc(pt);
 964 
 965 dcl       (p,pt,q,p1,q1,p2,s) ptr;
 966 dcl       c_offset fixed bin(24);
 967 dcl       p1_unal ptr unal auto;        /* used for better code in the comparisons */
 968 
 969 
 970 begin:
 971           p = pt;
 972           if p=null then return;
 973           if p->node.type ^= reference_node then return;
 974           p1_unal, p1 = p->reference.symbol;
 975           if p1->node.type ^= symbol_node then return;
 976           s = p1->symbol.son;
 977           do while(s^=null);
 978           set_level = set_level + 1;
 979           call set((s->symbol.reference));
 980           set_level = set_level - 1;
 981           s = s->symbol.brother;
 982           end;
 983           if p->reference.aliasable
 984                     then do;
 985                               q = s_list;
 986                               do while(q^=null);
 987                               q1 = q->secondary.operation->reference.symbol;
 988                               if q->secondary.operation->reference.aliasable
 989                                    then if compare_alias(p1,q1)
 990                                         then do;
 991                                                   call free_them;
 992                                                   q1 = q->secondary.next;
 993                                                   call release_node(q,s_list,2);
 994                                                   q = q1;
 995                                                   go to next;
 996                                              end;
 997                               q = q->secondary.next;
 998 next:
 999                               end;
1000                               return;
1001                          end;
1002 
1003 /* If the set was done with a pseudovariable, set the argument of the pseudovariable */
1004 
1005           if p1 -> symbol.defined
1006                then call set((p -> reference.qualifier));
1007 
1008 /* if this variable has been the argument of string, unspec, real, or imag, we
1009    must remove all computations depending on this symbol because the offset and
1010    c_offset may have been changed during processing.  Also, ancestors may have
1011    been affected */
1012 
1013           if p1 -> symbol.overlayed_by_builtin & (p1 -> symbol.member | p1 -> symbol.dimensioned)
1014           then do;
1015                do while(p1 ^= null);
1016                     if ^ p1 -> symbol.overlayed_by_builtin | ^ (p1 -> symbol.member | p1 -> symbol.dimensioned)
1017                          then return;
1018                     q = s_list;
1019                     do while(q ^= null);
1020                          if q -> secondary.operation -> reference.symbol = p1   /* p1_unal not used because p1 changes */
1021                          then do;
1022                               call free_them;
1023                               q1 = q -> secondary.next;
1024                               call release_node(q,s_list,2);
1025                               q = q1;
1026                               end;
1027                          else q = q -> secondary.next;
1028                          end;
1029                     if set_level > 0
1030                          then return;
1031                     p1 = p1 -> symbol.father;
1032                     end;
1033                return;
1034                end;
1035 
1036 /* if this is an array element with variable offset or array reference or string, remove all computations     */
1037 /* that are a function of any element of this array or string.                  */
1038 
1039           if (p1->symbol.array ^= null & (p->reference.array_ref | p-> reference.offset ^= null)) | p1->symbol.bit | p1->symbol.char
1040                     then do;
1041                               q=s_list;
1042                               do while(q^=null);
1043                               if q->secondary.operation->reference.symbol=p1_unal
1044                                         then do;
1045                                                   call free_them;
1046                                                   q1=q->secondary.next;
1047                                                   call release_node(q,s_list,2);
1048                                                   q=q1;
1049                                              end;
1050                                         else q=q->secondary.next;
1051                               end;
1052                     return;
1053                end;
1054 
1055 /* if this is an array element with constant offset, remove all computations
1056    that are a function of this element or any array reference or array
1057    element with variable offset of this array. handle storage_block
1058   references in a similar manner */
1059 
1060           if p1 -> symbol.array ^= null | p1 -> symbol.storage_block
1061           then do;
1062                q = s_list;
1063                c_offset = p -> reference.c_offset;
1064                do while (q ^= null);
1065                     q1 = q -> secondary.operation;
1066                     if q1 -> reference.symbol = p1_unal
1067                     then if q1 -> reference.c_offset = c_offset | q1 -> reference.array_ref | q1 -> reference.offset ^= null
1068                          then do;
1069                               call free_them;
1070                               q1 = q -> secondary.next;
1071                               call release_node(q,s_list,2);
1072                               q = q1;
1073                               go to next_a;
1074                               end;
1075                     q = q -> secondary.next;
1076 next_a:
1077                     end;
1078                return;
1079                end;
1080 
1081 /* this is not an array element or array reference or string.                             */
1082 
1083           q=s_list;
1084           do while(q^=null);
1085           if q->secondary.operation->reference.symbol = p1_unal
1086                     then do;
1087                               call free_them;
1088                               call release_node(q,s_list,2);
1089                               return;
1090                          end;
1091           q=q->secondary.next;
1092           end;
1093           return;
1094 
1095 /* This entry frees all computations that depend on anything that can be set by a
1096    call to an external procedure, otherthan the arguments passed by-reference.  */
1097 
1098 external_call: entry;
1099 
1100 declare free_flag bit(1);
1101 
1102           q = s_list;
1103           do while(q^=null);
1104           q1 = q->secondary.operation;
1105           p2 = q1->reference.symbol->symbol.block_node;
1106           if p2 = null
1107                then free_flag = q1->reference.aliasable;
1108                else free_flag = q1->reference.aliasable|p2->block.flush_at_call;
1109           if free_flag
1110                     then do;
1111                               call free_them;
1112                               q1 = q->secondary.next;
1113                               call release_node(q,s_list,2);
1114                               q = q1;
1115                          end;
1116                     else q = q->secondary.next;
1117           end;
1118           return;
1119 
1120 /* subroutine to free all primary list entries that depend on the secondary
1121    entry identified by the pointer q.  */
1122 
1123 free_them: proc;
1124 
1125 dcl       p1 ptr;
1126 
1127 begin:
1128           p1 = q->secondary.primary;
1129           do while(p1^=null);
1130           call release_node((p1->chain.value),p_list,1);
1131           if p1->chain.next=null
1132                     then do;
1133                               p1->chain.next = freec;
1134                               freec = q->secondary.primary;
1135                               return;
1136                          end;
1137           p1 = p1->chain.next;
1138           end;
1139 
1140           end free_them;
1141 
1142 %include compare_alias;
1143           end set;
1144 
1145 /* these routines are utility programs to create and free nodes       */
1146 /* i=0 for statement list primary nodes. i=1 for p_list primary nodes. i=2 for secondary nodes. */
1147 
1148 release_node: proc(pt,list_head,i);
1149 
1150 dcl       (p,pt,list_head) ptr;
1151 dcl       i fixed bin(15);
1152 
1153 begin:
1154           p = pt;
1155           if p->primary.computation = null
1156                     then return;                  /* this is an attempt to release an already freed primary */
1157           if p->primary.next ^=null
1158                     then p->primary.next->primary.last=p->primary.last;
1159           if p->primary.last =null
1160                     then list_head=p->primary.next;
1161                     else p->primary.last->primary.next=p->primary.next;
1162           if i=1
1163                     then do;                                /* this is a primary node */
1164                               if freep = null then freep_tail = p;
1165                               p->primary.computation=null;  /* null indicates that it is free */
1166                               p->primary.next=freep;
1167                               freep=p;
1168                               if p=p_tail then p_tail=p->primary.last;
1169                          end;
1170                     else do;
1171                               p->primary.next = free;
1172                               free=p;
1173                          end;
1174           p->primary.last=null;
1175           end release_node;
1176 
1177 
1178 create_node: proc(list_head,i) returns(ptr);
1179 
1180 dcl       (list_head,p) ptr;
1181 dcl       i fixed bin(15);
1182 
1183 begin:
1184           if free = null
1185                     then p = create_list(4);
1186                     else do;
1187                               p=free;
1188                               free=free->list.element(4);
1189                          end;
1190           p->list.element(3)=null;
1191           p->list.element(4)=list_head;
1192           if i=1 & list_head=null then p_tail=p;
1193           if list_head ^= null then list_head->list.element(3)=p;
1194           list_head=p;
1195           return(p);
1196           end create_node;
1197 
1198 
1199 /* erase everything from the primary and secondary lists.  */
1200 
1201 clear: proc;
1202 
1203           call erase;
1204           if p_tail ^= null
1205                     then do;
1206                               p_tail->list.element(4) = free;
1207                               free = p_list;
1208                               p_list,p_tail = null;
1209                          end;
1210           end clear;
1211 
1212 /* erase all primaries except those whose operands are constants. */
1213 
1214 erase: proc;
1215 
1216 dcl       (p,q) ptr;
1217 
1218 begin:
1219           q=s_list;
1220           do while(q^=null);
1221           p=q->secondary.primary;
1222           do while(p^=null);
1223           if p->chain.value->primary.computation ^= null
1224                then call release_node((p->chain.value),p_list,1);
1225           if p->chain.next = null
1226                     then do;
1227                               p->chain.next=freec;
1228                               freec=q->secondary.primary;
1229                               go to continue;
1230                          end;
1231           p=p->chain.next;
1232           end;
1233 continue:
1234           call release_node(q,s_list,2);
1235           q=s_list;
1236           end;
1237 
1238 /* put free primaries on the free list.  It is safe to do this because no
1239 more secondaries exist and therefore no references exist.                       */
1240 
1241 /* the primary list may still contain computations whose operands are constants */
1242 
1243           if freep_tail ^= null
1244                     then do;
1245                               freep_tail->primary.next=free;
1246                               free=freep;
1247                               freep_tail,freep=null;
1248                          end;
1249           end erase;
1250 
1251 
1252 /* this routine gets the intersection of the p_list and the primary list
1253 attached to the statement node.  If i=2 the statement node list is replace by this intersection.
1254 If i=1 the primary list p_list is replaced by the intersection.  If the state has been
1255 discarded and i = 2, the primary list p_list is replaced by the union of p_list and the
1256 statement node list.  */
1257 
1258 intersection: proc(pstate,p_i);
1259 
1260 dcl       (pstate,state,p,q,t) ptr;
1261 dcl       (i,n,p_i) fixed bin(15);
1262 
1263 begin:
1264           state = pstate;
1265           i = p_i;
1266 
1267           n = 0;
1268           do q=state->statement.labels repeat q->list.element(1) while(q^=null);
1269                n = n + 1;
1270           end;
1271 
1272           if state -> statement.ref_count_copy = 0 then state -> statement.ref_count_copy =
1273            state -> statement.reference_count;
1274 
1275           if i=1 & state->statement.ref_count_copy ^= n
1276                     then do;
1277                               call clear;
1278                               q=state->statement.reference_list;
1279                               do while(q^=null);
1280                               t = state -> statement.reference_list;
1281                               call release_node(q,t,0);
1282                               q, state->statement.reference_list = t;
1283                               end;
1284                               return;
1285                          end;
1286 
1287           if ^state->statement.optimized  /* label was never referenced */
1288           then if i=1 | state->statement.ref_count_copy = n
1289                then return;
1290 
1291           if i = 2 & state_is_discarded & p_list = null
1292           then do;
1293                do p = state -> statement.reference_list repeat p -> primary.next while(p ^= null);
1294                     t = create_node(p_list,1);
1295                     t -> primary.computation = p -> primary.computation;
1296                     t -> primary.statement = p -> primary.statement;
1297                     call record_secondaries((t -> primary.computation),1);
1298                     end;
1299                state_is_discarded = "0"b;
1300                return;
1301                end;
1302 
1303           if i=2 then p=state->statement.reference_list;
1304                     else p=p_list;
1305           do while(p^=null);
1306           if i=2 then q=p_list;
1307                     else q=state->statement.reference_list;
1308           do while(q^=null);
1309           if q->primary.computation = p->primary.computation
1310                     then do;
1311                               p=p->primary.next;
1312                               go to next;
1313                          end;
1314           q=q->primary.next;
1315           end;
1316 
1317 /* this element is not common to both lists, remove it (or if i = 2 &
1318    state_is_discarded, add it to p_list).  */
1319 
1320           q=p->primary.next;
1321           if i=2
1322           then if state_is_discarded
1323                then do;
1324                     t = create_node(p_list,1);
1325                     t -> primary.computation = p -> primary.computation;
1326                     t -> primary.statement = p -> primary.statement;
1327                     call record_secondaries((t -> primary.computation),1);
1328                     end;
1329                else do;
1330                     t = state -> statement.reference_list;
1331                     call release_node(p,t,0);
1332                     state -> statement.reference_list = t;
1333                     end;
1334           else call release_node(p,p_list,1);
1335           p=q;
1336 next:
1337           end;
1338 
1339           if i = 2 then state_is_discarded = "0"b;
1340 
1341 
1342           end intersection;
1343 
1344 
1345 dump_primary: entry;
1346 dcl       display_exp entry(ptr);
1347           do q = p_list repeat q->primary.next while(q^=null);
1348           call display_exp((q->primary.computation));
1349           call ioa_("^/");
1350           end;
1351           return;
1352 
1353 dump_secondary: entry;
1354           do q = s_list repeat q->secondary.next while(q^=null);
1355           call display_exp((q->secondary.operation));
1356           call ioa_("^/");
1357           end;
1358           return;
1359      end /* optimizer */;