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 /* Procedure to compile root operator of a statement
  12 
  13    Initial Version: 16 April 1971 by BLW
  14           Modified: 29 December 1972 by BLW
  15           Modified: 28 February 1973 by RAB
  16           Modified: 18 June 1973 by RAB
  17           Modified: 6 October 1973 by RAB for EIS
  18           Modified: 23 June 1976 by R. Schoeman for new area package
  19           Modified: 24 June 1976 by RAB to centralize use of cg_stat$last_call
  20           Modified: 30 January 1977 by RAB to dec ref_count in allot_ctl & free_ctl
  21           Modified: 15 April 1979 by RAB to improve code for a = a & b; for
  22                     based long strings by checking for allowable cases of overlap
  23           Modified: 17 August 1979 by RAB to improve code for a = a & ^ b; for long strings.
  24                     One instruction is generated instead of two or more.
  25           Modified 791016 by PG to fix 1856 (multiple assignment code bumped ref count on
  26                     a shared reference node owned by a top-level bound_ck operator!)
  27           Modified 830106 by BIM to align aggregate loops on doubleword
  28                     boundaries.
  29 */
  30 
  31 compile_tree: proc(pt);
  32 
  33 /* parameters */
  34 
  35 dcl       pt ptr parameter;             /* point at an operator node */
  36 
  37 /* external static */
  38 
  39 dcl       (cg_stat$prol_ent,cg_stat$cur_block,cg_stat$cur_statement,cg_stat$cur_node,cg_stat$cur_tree) ptr ext,
  40           cg_stat$text_pos fixed bin(18) ext;
  41 
  42 /* automatic */
  43 
  44 dcl       (p,arg(3),llp,ulp,p1,q1,p2,q2,q3,s1,s2,rand(10),save_cur_node) ptr,
  45           macro fixed bin(15),
  46           op_code bit(9),
  47           (atomic,abset) bit(1) aligned,
  48           (i,j,k,loc,n,cfo,d) fixed bin;
  49 
  50 /* based */
  51 
  52 dcl       fix_bin             fixed bin based;
  53 
  54 /* defined */
  55 
  56 dcl       op_class bit(5) defined(op_code) pos(1);
  57 
  58 /* entries */
  59 
  60 dcl       (assign_op,compile_tree,compile_exp,move_data,
  61            state_man$flush_ref,jump_op,io_op) entry(ptr);
  62 dcl       m_a entry(ptr,bit(2) aligned);
  63 dcl       base_man$load_var entry(fixed bin,ptr,fixed bin),
  64           base_to_core entry(fixed bin,ptr),
  65           base_man$store_ptr_to entry(ptr,ptr),
  66           base_man$update_base entry(fixed bin,ptr,fixed bin);
  67 dcl       compare_expression entry(ptr,ptr) returns(bit(1) aligned) reducible;
  68 dcl       adjust_ref_count entry(ptr,fixed bin),
  69           call_op entry(ptr) returns(ptr),
  70           compile_exp$save entry(ptr) returns(ptr),
  71           compile_exp$save_exp entry(ptr) returns(ptr),
  72           load entry(ptr,fixed bin),
  73           create_label entry(ptr,ptr,bit(3) aligned) returns(ptr),
  74           store$force entry(ptr),
  75           xr_man$load_const entry(fixed bin(31),fixed bin),
  76           (state_man$flush,io_op$init_ps) entry,
  77           state_man$erase_reg entry(bit(19) aligned),
  78           state_man$set_aliasables entry(ptr),
  79           c_a entry(fixed bin,fixed bin) returns(ptr),
  80           aq_man$clear_q entry,
  81           expmac$one entry(fixed bin(15),ptr,fixed bin),
  82           expmac$zero entry(fixed bin(15)),
  83           expmac$many entry(fixed bin(15),ptr,fixed bin),
  84           expmac$two_eis entry(fixed bin(15),ptr,ptr),
  85           prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
  86           expmac entry(fixed bin(15),ptr),
  87           decimal_op$change_target entry(ptr) returns(bit(1) aligned),
  88           decimal_op$get_float_temp entry(fixed bin(24),bit(1) aligned) returns(ptr),
  89           assign_op$to_dec_scaled entry(ptr,ptr),
  90           stack_temp$assign_aggregate entry(ptr);
  91 
  92 /* builtins */
  93 
  94 dcl       (addr,fixed,mod,null) builtin;
  95 
  96 /* internal static */
  97 
  98 dcl       odd_bases bit(19) aligned int static init("0000000000000001111"b);
  99 
 100 dcl (     call_prologue       init(204),
 101           aos_mac             init(309),
 102           nop_mac             init(528),
 103           incr_mac            init(310),
 104           diff_mac            init(311),
 105           allot_auto_mac      init(114),
 106           zero_mac            init(308),
 107           open_mac            init(493),
 108           close_mac           init(494),
 109           make_desc_mac       init(275),
 110           arl                 init(245),
 111           lrl                 init(62),
 112           signal_mac          init(289),
 113           io_signal_mac       init(321),
 114           revert_mac          init(290),
 115           revert_file         init(607),
 116           string_mac(33:35)   init(43,49,55),
 117           long_mac(33:35)     init(264,304,341),
 118           move_andnot_1       init(392),
 119           set_desc_size       init(276),
 120           alloc_block         init(608),
 121           free_block          init(609),
 122           alloc_based_area    init(502),
 123           alloc_based_mac     init(695),
 124           free_based_mac      init(696),
 125           empty_area_mac      init(697),
 126           push_ctl_data       init(610),
 127           push_ctl_desc       init(611),
 128           pop_ctl_data        init(612),
 129           pop_ctl_desc        init(613),
 130           loop_end            init(397)) fixed bin(15) int static options (constant);
 131 
 132 dcl (     jump_class          init("00101"b),
 133           ptr_class           init("01011"b),
 134           io_class            init("10000"b)) bit(5) int static options (constant);
 135 
 136 /* include files */
 137 
 138 %include cgsystem;
 139 %include block;
 140 %include statement;
 141 %include operator;
 142 %include reference;
 143 %include symbol;
 144 %include label;
 145 %include nodes;
 146 %include declare_type;
 147 %include op_codes;
 148 %include data_types;
 149 %include boundary;
 150 %include list;
 151 ^L
 152 /* program */
 153 
 154           p, cg_stat$cur_tree = pt;
 155           op_code = p -> operator.op_code;
 156 
 157           if op_code = join
 158           then do;
 159 
 160                do i = 1 to p -> operator.number;
 161                     call compile_tree((p -> operand(i)));
 162                     end;
 163 
 164                return;
 165                end;
 166 
 167           if op_class = jump_class
 168           then do;
 169                call jump_op(pt);
 170                return;
 171                end;
 172 
 173           do i = 1 to p -> operator.number;
 174                rand(i) = p -> operand(i);
 175                end;
 176 
 177           if p -> operator.number > 1
 178           then if rand(1) ^= null
 179           then if rand(1) -> node.type = reference_node
 180           then if rand(1) -> reference.evaluated
 181           then if ^ rand(1) -> reference.shared
 182           then do;
 183                call adjust_ref_count(rand(1),-1);
 184                return;
 185                end;
 186 
 187           if op_code = std_call
 188           then do;
 189                p = call_op(p);
 190                return;
 191                end;
 192 
 193           if op_code = assign_zero
 194           then do;
 195                p = prepare_operand(rand(1),1,atomic);
 196                call state_man$flush_ref(p);
 197                call expmac((zero_mac),p);
 198                if p -> reference.aliasable
 199                     then call state_man$set_aliasables(p);
 200                return;
 201                end;
 202 
 203           if op_code = ex_prologue
 204           then do;
 205 
 206                p = cg_stat$cur_block;
 207                if p -> block.number_of_entries = 1
 208                then do;
 209 
 210                     /* instead of compiling the prologue as a subroutine, we'll
 211                        hook all of the prologue statements into the main list
 212                        after the current statement */
 213 
 214                     if p -> block.plio_ps ^= null then call io_op$init_ps;
 215 
 216                     arg(1) = cg_stat$cur_statement;
 217                     arg(2) = p -> block.end_prologue;
 218                     if arg(2) = null then return;
 219                     arg(2) -> statement.next = arg(1) -> statement.next;
 220                     arg(2) -> statement.next -> statement.back = arg(2);
 221                     arg(2) = p -> block.prologue;
 222                     arg(1) -> statement.next = arg(2);
 223                     arg(2) -> statement.back = arg(1);
 224                     p -> block.prologue, p -> block.end_prologue = null;
 225                     end;
 226 
 227                else if cg_stat$prol_ent ^= null
 228                     then do;
 229                          call state_man$erase_reg((odd_bases));
 230                          call expmac((call_prologue),prepare_operand(cg_stat$prol_ent,1,atomic));
 231                          end;
 232 
 233                return;
 234                end;
 235 
 236           if op_code = loop
 237           then do;
 238 
 239                call check_aggregate(rand(1));
 240 
 241                arg(2) = prepare_operand(rand(2),1,atomic);
 242 
 243                ulp = prepare_operand(rand(4),1,atomic);
 244                if ^ atomic then ulp = compile_exp$save(rand(4));
 245 
 246                if ulp -> reference.data_type = real_fix_bin_2 then ulp -> reference.c_offset = ulp -> reference.c_offset + 1;
 247 
 248                llp = prepare_operand(rand(3),1,atomic);
 249                if atomic then call load(llp,0); else call compile_exp(rand(3));
 250 
 251                call store$force(arg(2));
 252 
 253                call state_man$flush;
 254 
 255                if mod (cg_stat$text_pos, 2) ^= 0
 256                then call expmac$zero (nop_mac);
 257                arg(1) = create_label(cg_stat$cur_block,null,(by_compiler));
 258                arg(1) -> label.location = cg_stat$text_pos;
 259                arg(1) -> label.allocated = "1"b;
 260                arg(1) = prepare_operand(arg(1),1,atomic);
 261 
 262                call compile_tree(rand(1));
 263 
 264                arg(3) = ulp;
 265                call expmac$many((loop_end),addr(arg),3);
 266 
 267                if ulp -> reference.data_type = real_fix_bin_2 then ulp -> reference.c_offset = ulp -> reference.c_offset - 1;
 268 
 269                /* release scalar expressions pulled outside of loop as optimization */
 270 
 271                do p1 = rand(5) repeat p1 -> element(1) while(p1 ^= null);
 272                     call adjust_ref_count((p1 -> element(2)),-1);
 273                     end;
 274 
 275                return;
 276                end;
 277 
 278           if op_code = allot_auto
 279           then do;
 280                q2 = prepare_operand(rand(2),1,atomic);
 281                if atomic then call load(q2,0); else call compile_exp(rand(2));
 282                call expmac((allot_auto_mac),rand(1));
 283                call base_man$update_base(1,rand(1),1);
 284                return;
 285                end;
 286 
 287           if op_code = make_desc
 288           then do;
 289 
 290                do i = 1 to 3;
 291                     arg(i) = prepare_operand(rand(i),1,atomic);
 292                     end;
 293 
 294                if atomic then call load(arg(3),0); else call compile_exp(rand(3));
 295 
 296                if arg(1) ^= arg(2) then call expmac$many((make_desc_mac),addr(arg),2);
 297                else do;
 298                     call m_a(arg(1),"0"b);
 299                     arg(1) -> reference.perm_address = "1"b;
 300 
 301                     if arg(1) -> address.tag
 302                     then do;
 303                          call base_man$load_var(2,arg(1),1);
 304                          arg(1) -> reference.perm_address = "1"b;
 305                          end;
 306 
 307                     arg(1) -> address.tag = "001111"b;
 308                     call expmac((set_desc_size),arg(1));
 309                     end;
 310 
 311                return;
 312                end;
 313 
 314           if op_code = copy_words
 315           then do;
 316 l4:            call move_data(p);
 317                abset = "0"b;
 318                call set_structure(rand(1));
 319                return;
 320                end;
 321 
 322           if op_code = copy_string then goto l4;
 323 
 324           if op_class = io_class
 325           then do;
 326                save_cur_node = cg_stat$cur_node;
 327                cg_stat$cur_node = pt;
 328                call io_op(pt);
 329                cg_stat$cur_node = save_cur_node;
 330                call state_man$set_aliasables(null);
 331                return;
 332                end;
 333 
 334           if op_code = open_file
 335           then do;
 336                macro = open_mac;
 337                goto l6;
 338                end;
 339 
 340           if op_code = close_file
 341           then do;
 342                macro = close_mac;
 343 
 344 l6:            call state_man$erase_reg((odd_bases));
 345                call expmac$zero(macro);
 346                call state_man$set_aliasables(null);
 347                return;
 348                end;
 349 
 350           if op_code = signal_on
 351           then do;
 352 
 353                if rand(2) = null then macro = signal_mac;
 354                else do;
 355                     p2 = prepare_operand(rand(2),1,atomic);
 356                     call base_man$store_ptr_to(p2,c_a(40,4));
 357                     macro = io_signal_mac;
 358                     end;
 359 
 360                p1 = prepare_operand((rand(1) -> reference.symbol -> symbol.general),1,atomic);
 361                call xr_man$load_const((p1 -> reference.c_length),6);
 362                call expmac(macro,p1);
 363                call state_man$flush;
 364                return;
 365                end;
 366 
 367           if op_code = revert_on
 368           then do;
 369                if rand(2) = null
 370                then call expmac((revert_mac),c_a((rand(1) -> reference.symbol -> symbol.location),4));
 371                else do;
 372                     arg(1) = prepare_operand((rand(1) -> reference.symbol -> symbol.general),1,atomic);
 373                     arg(2) = prepare_operand(rand(2),1,atomic);
 374                     call expmac$many((revert_file),addr(arg),2);
 375                     end;
 376 
 377                return;
 378                end;
 379 
 380           if op_code = nop
 381           then do;
 382                call expmac$zero((nop_mac));
 383                return;
 384                end;
 385 
 386           s1 = rand(1) -> reference.symbol;
 387 
 388           if op_code = allot_ctl
 389           then do;
 390                     q2 = prepare_operand(rand(2),1,atomic);
 391                     if atomic
 392                          then call load(q2,0);
 393                          else call compile_exp(rand(2));
 394                     if s1->symbol.arg_descriptor
 395                          then macro = push_ctl_desc;
 396                          else if s1->symbol.exp_extents
 397                                    then macro = alloc_block;
 398                                    else macro = push_ctl_data;
 399                     go to ca;
 400                end;
 401 
 402           if op_code = free_ctl
 403           then do;
 404                     if s1->symbol.arg_descriptor
 405                          then macro = pop_ctl_desc;
 406                          else if s1->symbol.exp_extents
 407                                    then macro = free_block;
 408                                    else macro = pop_ctl_data;
 409 ca:                 loc = s1->symbol.location;
 410                     if s1->symbol.internal
 411                          then do;
 412                               n = 13;
 413                               if s1->symbol.arg_descriptor
 414                                    then loc = loc - 2;
 415                               end;
 416                          else n = 9;
 417                     q1 = c_a(loc,n);
 418                     call state_man$erase_reg((odd_bases));
 419                     call expmac(macro,q1);
 420                     if ^ rand(1) -> reference.shared
 421                          then call adjust_ref_count(rand(1),-1);
 422                     call state_man$set_aliasables(null);
 423                     abset = "1"b;
 424                     call set_structure(rand(1));
 425                     return;
 426                end;
 427 
 428                     /* The schematic code sequence for allot_based    */
 429                     /* is as follows:   */
 430                     /*  <prepare ptr>             */
 431                     /*  <flush all registers>     */
 432                     /*RE-TRY:           */
 433                     /*  <prepare area> (if it exists)       */
 434                     /*  <compile size(based_var)> */
 435                     /*  epp2 area (if it exists)  */
 436                     /*  <flush all regs>          */
 437                     /*  tsx0  pr0|alloc_based if area given,          */
 438                     /*  or tsx0 pr0|alloc_based_storage if area not given       */
 439                     /*  tra RE-TRY                */
 440                     /*  spri2 _^Hp_^Ht_^Hr (to area)        */
 441 
 442           if op_code = allot_based
 443           then do;
 444                q1 = prepare_operand(rand(1),1,atomic);
 445 
 446                call state_man$flush;
 447                loc = cg_stat$text_pos;
 448 
 449                if rand(3)^= null
 450                then q3 = prepare_operand(rand(3),1,atomic);
 451 
 452                q2 = prepare_operand(rand(2),1,atomic);
 453                if atomic
 454                then call load(q2,0);
 455                else call  compile_exp(rand(2));
 456 
 457                p1 = c_a(loc,10);
 458                if rand(3) ^=  null
 459                then do;
 460                     call base_man$load_var(2,q3,1);
 461                     macro = alloc_based_area;
 462                     end;
 463                else macro = alloc_based_mac;
 464 
 465                call state_man$flush;
 466 
 467                call expmac(macro,p1);
 468                call base_to_core(1,q1);
 469 
 470                return;
 471                end;
 472 
 473                     /* The schematic code sequence for free_based is: */
 474                     /* <evaluate size (based_var)>          */
 475                     /* <evaluate area>  */
 476                     /* epp5 qualifier_of_based_var          */
 477                     /* <flush all regs> */
 478                     /* tsx0 pr0|free_based        */
 479 
 480           if op_code = free_based
 481           then do;
 482                q2 = prepare_operand(rand(2),1,atomic);
 483                if ^atomic
 484                then call compile_exp(rand(2));
 485                else call adjust_ref_count(q2,-1);
 486 
 487                if rand(3) ^= null
 488                then do;
 489                     q3 = prepare_operand(rand(3),1,atomic);
 490                     if ^atomic
 491                     then call compile_exp(rand(3));
 492                     else call adjust_ref_count(q3,-1);
 493 
 494                     end;
 495 
 496                q1 = prepare_operand(rand(1),-1,atomic);
 497 
 498                p2 = q1->reference.qualifier;
 499 
 500                if p2->node.type = operator_node
 501                then do;
 502 
 503                     /* check for evaluated because addr_fun handled specially */
 504 
 505                     if ^ p2 -> operand(1) -> reference.evaluated
 506                          then p2 = compile_exp$save(p2);
 507                          else p2 = p2 -> operand(1);
 508                     end;
 509 
 510                if ^ p2 -> reference.shared
 511                     then p2->reference.ref_count = p2->reference.ref_count + 1;
 512                call base_man$load_var(2,p2,5);
 513 
 514                call state_man$flush;
 515 
 516                call expmac$zero((free_based_mac));
 517 
 518                call adjust_ref_count(q1,-1);
 519 
 520                return;
 521 
 522                end;
 523 
 524                     /* The schematic code sequence for free_based is :          */
 525                     /* <compile size>   */
 526                     /* epp2 area        */
 527                     /* <flush all regs> */
 528                     /* tsx0 pr0|empty   */
 529 
 530           if op_code = empty_area
 531           then do;
 532                q1 = prepare_operand(rand(1),1,atomic);
 533 
 534                q2 = prepare_operand(rand(2),1,atomic);
 535                if ^atomic
 536                then call compile_exp(rand(2));
 537                else call load(q2,0);
 538 
 539                call base_man$load_var(2,q1,1);
 540 
 541                call state_man$flush;
 542 
 543                call expmac$zero((empty_area_mac));
 544 
 545                return;
 546 
 547                end;
 548 
 549           if op_class = ptr_class then goto ce;
 550 
 551 /* All of the code from here to the call to compile_exp is here to handle
 552    the special-cases that arise from operator_semantics eliminating assign
 553    operators at the top of the tree. However, the following code is general
 554    in that is it safe to perform these optimizations no matter what the
 555    origin of the tree. */
 556 
 557           /* The following code adjusts the reference count on T in the case
 558                               T = right_hand_side
 559                               a = T
 560                               b = T
 561              which arises from the multiple assignment
 562                               a,b = right_hand_side
 563             or from the assignment
 564                               bit_string = unspec(right_hand_side)    */
 565 
 566           if s1 -> symbol.temporary & ^rand(1) -> reference.shared
 567           then if rand (1) -> reference.ref_count > 1
 568                then rand (1) -> reference.ref_count = rand (1) -> reference.ref_count - 1;
 569 
 570           if (op_code = assign) | (op_code = assign_size_ck)
 571           then do;
 572                if op_code = assign_size_ck
 573                then go to l0;
 574 
 575                /* The following uses the fact the all decimal operations are done by special hardware and
 576                   most complex binary operations are done via calls to procedures both of which are
 577                   able to accept an output operand whose attributes are different than
 578                   those required by the PL/I precision rules.  The fact that the
 579                   semantic translator generated an assigment operator means that
 580                   the attributes of the LHS do not match those of the RHS.  If RHS
 581                   is an expression which has not been optimized or previously
 582                   evaluated, we will attempt to eliminate the assign operator ourselves
 583                   if the runtime routines can handle the attribute mismatch that will
 584                   result.  This eliminates the need for an extra procedure call at
 585                   runtime to move the result of the computation into LHS */
 586 
 587                if rand(2) -> node.type ^= operator_node then goto l0;
 588 
 589                p1 = rand(2) -> operand(1);
 590                if p1 -> reference.evaluated then goto l0;
 591                if p1 -> reference.ref_count > 0 then goto l0;
 592 
 593                s2 = p1 -> reference.symbol;
 594 
 595                /* Both sides have to have same value for complex and decimal attributes */
 596 
 597                if s1 -> symbol.complex ^= s2 -> symbol.complex then goto l0;
 598                if s2 -> symbol.decimal ^= s1 -> symbol.decimal then goto l0;
 599 
 600                if s1 -> symbol.decimal
 601                then do;
 602 
 603                     /* Make sure scales are within hardware limits */
 604 
 605                     if s1 -> symbol.scale > max_dec_scale then go to l0;
 606                     if s1 -> symbol.scale < min_dec_scale then go to l0;
 607                     if s2 -> symbol.scale > max_dec_scale then go to l0;
 608                     if s2 -> symbol.scale < min_dec_scale then go to l0;
 609 
 610                     /* some operators require results with special characteristics */
 611 
 612                     if rand(2) -> operator.op_code = trunc_fun
 613                     then if s1 -> symbol.scale ^= 0 | (s1 -> symbol.float & s2 -> symbol.fixed)
 614                          then go to l0;
 615                     if rand(2) -> operator.op_code = assign
 616                     then do;
 617                          if s1 -> symbol.float & s2 -> symbol.fixed
 618                               then go to l0;
 619                          if s1 -> symbol.fixed & s2 -> symbol.fixed
 620                          then if s1 -> symbol.scale ^= s2 -> symbol.scale
 621                               then go to l0;
 622                          if s1 -> symbol.c_dcl_size > s2 -> symbol.c_dcl_size
 623                               then go to l0;
 624                          end;
 625                     if rand(2) -> operator.op_code = round_fun then go to l0;
 626                     if rand(2) -> operator.op_code = min_fun then go to l0;
 627                     if rand(2) -> operator.op_code = max_fun then go to l0;
 628                     if rand(2) -> operator.op_code = unpack then go to l0;
 629 
 630                     /* any real decimal can be replaced by any other real decimal
 631                        and similarly for complex decimals */
 632 
 633 switch:             rand(2) -> operand(1) = rand(1);
 634                     p = rand(2);
 635                     goto ce;
 636                     end;
 637 
 638                if ^ s1 -> symbol.complex then goto l0;
 639 
 640                /* If output of RHS is float binary single, we only want to
 641                   replace it if LHS is float binary single aligned.  Otherwise,
 642                   we can replace a complex float binary with any other
 643                   complex float binary and similarly for complex fixed binary */
 644 
 645                if s2 -> symbol.float
 646                then if s2 -> symbol.c_word_size = 1
 647                     then do;
 648                          if ^ s1 -> symbol.float then goto l0;
 649                          if s1 -> symbol.c_word_size ^= 1 then goto l0;
 650                          if s1 -> symbol.packed then goto l0;
 651 
 652                          if rand(1) -> reference.units ^= 0
 653                          then if rand(1) -> reference.units ^= word_
 654                               then goto l0;
 655 
 656                          goto switch;
 657                          end;
 658 
 659                if s2 -> symbol.float = s1 -> symbol.float then goto switch;
 660 
 661                /* could not eliminate the assignment */
 662 
 663 l0:            call assign_op(p);
 664                go to set;
 665                end;
 666 
 667           /* the following code checks for decimal expressions whose scale
 668              is outside of machine limits */
 669 
 670           if s1 -> symbol.decimal
 671           then if s1 -> symbol.fixed
 672           then if p -> operator.number >= 3
 673           then if op_code ^= round_fun
 674           then if op_code ^= complex_fun
 675           then do;
 676                if s1 -> symbol.scale < min_dec_scale | s1 -> symbol.scale > max_dec_scale
 677                then do;
 678                     if decimal_op$change_target(p)
 679                     then do;
 680                          p -> operand(1) = decimal_op$get_float_temp(s1 -> symbol.c_dcl_size,(s1 -> symbol.complex));
 681                          p1 = compile_exp$save(p);
 682                          rand(1) = prepare_operand(rand(1),1,atomic);
 683                          call assign_op$to_dec_scaled(rand(1),p1);
 684                          p -> operand(1) = rand(1);
 685                          go to set;
 686                          end;
 687                     end;
 688                go to ce;
 689                end;
 690 
 691           /* machine-dependent optimizations follow */
 692 
 693           if op_code = add | op_code = sub
 694           then do;
 695 
 696                /* if operand(1) is single fixed binary, we may be able to generate
 697                   a shorter code sequence if two of the operands are the same */
 698 
 699 
 700                if s1 -> symbol.complex then goto ce;
 701                if s1 -> symbol.float then goto ce;
 702                if s1 -> symbol.unaligned then goto ce;
 703 
 704                if s1 -> symbol.c_dcl_size > max_p_fix_bin_1 then goto ce;
 705 
 706                if ^ search_arithmetic() then go to ce;
 707 
 708                q1 = prepare_operand(rand(1),1,atomic);
 709 
 710                call drop_count;
 711 
 712                if i = 2 then j = 3; else j = 2;
 713 
 714                p2 = p -> operand(j);
 715                q2 = prepare_operand(p2,1,atomic);
 716 
 717                if op_code = sub then goto l2;
 718 
 719                if atomic
 720                then do;
 721                     s2 = q2 -> reference.symbol;
 722                     if s2 -> symbol.constant
 723                     then if q2 -> reference.offset = null
 724                          then if q2 -> reference.c_offset = 0
 725                               then if s2 -> symbol.initial -> fix_bin = 1
 726                                    then do;
 727                                         macro = aos_mac;
 728                                         goto l3;
 729                                         end;
 730 
 731                     call load(q2,0);
 732                     end;
 733                else call compile_exp(p2);
 734 
 735 l1a:           macro = incr_mac;
 736                goto l3;
 737 
 738 l2:            if i = 2
 739                then do;
 740                     if ^ atomic then q2 = compile_exp$save(p2);
 741                     call load(q2,1);
 742                     goto l1a;
 743                     end;
 744 
 745                if atomic then call load(q2,0); else call compile_exp(p2);
 746 
 747                macro = diff_mac;
 748 
 749 l3:            call state_man$flush_ref(q1);
 750                call expmac(macro,q1);
 751                go to set;
 752                end;
 753 
 754           if op_class = "00010"b                            /* and, or, not, etc */
 755           then do;
 756                if op_code > xor_bits then goto ce;
 757 
 758                /* have &, |, or xor operator */
 759 
 760                if rand(1) -> reference.length ^= null | rand(1) -> reference.c_length > bits_per_two_words
 761                then do;
 762                     if ^ search() then go to ce;
 763 
 764                     macro = long_mac(fixed(op_code,9));
 765 
 766                     if i = 2 then j = 3; else j = 2;
 767 
 768                     q1 = prepare_operand(rand(1),1,atomic);
 769                     p2 = prepare_operand(rand(j),1,atomic);
 770 
 771                     if rand(j) -> node.type = reference_node
 772                     then if overlaps(q1,p2)
 773                          then go to ce;
 774                          else;
 775 
 776                     else if can_do_andnot(rand(j))
 777                          then do;
 778 
 779                               /* op_code is and_bits, rand(j) is not_bits */
 780 
 781                               p2 = prepare_operand((rand(j) -> operand(2)),1,atomic);
 782 
 783                               if ^ atomic
 784                                    then p2 = compile_exp$save_exp((rand(j) -> operand(2)));
 785 
 786                               call adjust_ref_count((rand(j) -> operand(1)), -1);
 787 
 788                               macro = move_andnot_1;
 789                               end;
 790 
 791                          else p2 = compile_exp$save(rand(j));
 792 
 793                     call drop_count;
 794 
 795                     call expmac$two_eis(macro,q1,p2);
 796                     go to set;
 797                     end;
 798 
 799                if rand(1) -> reference.offset ^= null then goto ce;
 800                if rand(1) -> reference.fo_in_qual then goto ce;
 801 
 802                cfo = mod(rand(1) -> reference.c_offset * convert_offset(rand(1) -> reference.units),bits_per_word);
 803                k = cfo + rand(1) -> reference.c_length;
 804                if k > bits_per_two_words then goto ce;
 805 
 806                if ^ search() then go to ce;
 807 
 808                q1 = prepare_operand(rand(1),1,atomic);
 809 
 810                if ^ (q1 -> reference.aligned_ref | op_code = or_bits) then goto ce;
 811 
 812                call drop_count;
 813 
 814                if i = 2 then j = 3; else j = 2;
 815                p2 = rand(j);
 816                q2 = prepare_operand(p2,1,atomic);
 817 
 818                d = fixed(k > bits_per_word,1);
 819 
 820                if atomic then call load(q2,d); else call compile_exp(p2);
 821 
 822                i = q2 -> reference.c_length;
 823                if op_code = and_bits
 824                then if fixed(i > bits_per_word,1) < d
 825                     then do;
 826                          call aq_man$clear_q;
 827                          i = bits_per_two_words;
 828                          end;
 829 
 830                i = cfo + i;
 831                d = fixed(i > bits_per_word,1);
 832 
 833                if cfo ^= 0
 834                then do;
 835                     if d = 0 then macro = arl; else macro = lrl;
 836                     call expmac(macro,c_a(cfo,1));
 837                     end;
 838 
 839                call state_man$flush_ref(q1);
 840                call expmac$one((string_mac(fixed(op_code,9))),q1,d);
 841                go to set;
 842                end;
 843 
 844 ce:       call compile_exp(p);
 845 
 846 set:      if rand(1) -> reference.aliasable
 847           then call state_man$set_aliasables(rand(1));
 848           else if rand(1) -> reference.defined_ref
 849                then do;
 850                     abset = "0"b;
 851                     call set_structure((rand(1) -> reference.qualifier));
 852                     end;
 853 
 854           return;
 855 ^L
 856 search:   proc returns(bit(1) aligned) irreducible;
 857 
 858           if rand(1) -> reference.units = 0
 859                then rand(1) -> reference.units = word_;
 860 
 861           do i = 2 to 3;
 862                q1 = rand(i);
 863                if rand(1) = q1 then return("1"b);
 864                if q1 -> node.type = reference_node
 865                then do;
 866                     if q1 -> reference.units = 0
 867                          then q1 -> reference.units = word_;
 868                     if rand(1) -> reference.symbol = q1 -> reference.symbol
 869                     then if compare_expression(rand(1),q1)
 870                          then return("1"b);
 871                     end;
 872                end;
 873 
 874           return("0"b);
 875 
 876           end;
 877 
 878 search_arithmetic:  proc returns(bit(1) aligned) irreducible;
 879 
 880           /* we cannot use compare_expression directly because some operands
 881              may be prepared while others may not, thus c_length may be invalid.
 882              compare_expression is used at all because if one operand is a call,
 883              the optimizer might be prevented from commoning the offsets and
 884              qualifiers of the other operands. */
 885 
 886           do i = 2 to 3;
 887                q1 = rand(i);
 888                if rand(1) = q1 then return("1"b);
 889                if q1 -> node.type = reference_node
 890                then if rand(1) -> reference.symbol = q1 -> reference.symbol
 891                then if rand(1) -> reference.c_offset = q1 -> reference.c_offset
 892                then do;
 893                     if rand(1) -> reference.qualifier ^= q1 -> reference.qualifier
 894                     then if ^ compare_expression((rand(1) -> reference.qualifier),(q1 -> reference.qualifier))
 895                          then go to step;
 896                     if rand(1) -> reference.offset ^= q1 -> reference.offset
 897                     then if ^ compare_expression((rand(1) -> reference.offset),(q1 -> reference.offset))
 898                          then go to step;
 899                     return("1"b);
 900                     end;
 901 step:
 902                end;
 903 
 904           return("0"b);
 905 
 906           end;
 907 
 908 drop_count:         proc;
 909 
 910           if ^ rand(i) -> reference.shared
 911                then call adjust_ref_count(rand(i),-1);
 912 
 913           end;
 914 ^L
 915 overlaps: proc(q1,p2) returns(bit(1) aligned);
 916 
 917 /* checks to see if two reference nodes reference overlapping but not matching storage.
 918    At least one of the reference nodes MUST be a non-temporary. */
 919 
 920 dcl            (q1,p2) ptr;
 921 
 922           if q1 -> reference.symbol = p2 -> reference.symbol
 923            | (q1 -> reference.aliasable & p2 -> reference.aliasable)
 924              & q1 -> reference.symbol -> symbol.aligned = p2 -> reference.symbol -> symbol.aligned
 925              & q1 -> reference.symbol -> symbol.varying = p2 -> reference.symbol -> symbol.varying
 926           then if q1 -> reference.substr
 927                 | p2 -> reference.substr
 928                 | ^ (q1 -> reference.symbol -> symbol.aligned | q1 -> reference.symbol -> symbol.varying)
 929                then return("1"b);
 930 
 931           return("0"b);
 932 
 933           end /* overlaps */;
 934 ^L
 935 set_structure:      proc(pt);
 936 
 937 /* We must flush the non-aggregate shared members of the structure from the machine state */
 938 
 939 dcl       (adam,pt,r,s) ptr;
 940 
 941           adam = pt -> reference.symbol;
 942 
 943           s = adam;
 944 
 945 loop:     do while(s -> symbol.structure);
 946           s = s -> symbol.son;
 947           end;
 948 
 949           r = s -> symbol.reference;
 950           if ^ r -> reference.array_ref
 951           then do;
 952                if r -> reference.qualifier = null
 953                then if r -> reference.offset = null
 954                     then if r -> reference.length = null
 955                          then call state_man$flush_ref(r);
 956 
 957                if ^ abset
 958                then if s -> symbol.aliasable | r -> reference.aliasable
 959                     then call state_man$set_aliasables(r);
 960                end;
 961 
 962           if s = adam then return;
 963 
 964           do while(s -> symbol.brother = null);
 965           s = s -> symbol.father;
 966           if s = adam then return;
 967           end;
 968 
 969           s = s -> symbol.brother;
 970           go to loop;
 971           end;
 972 ^L
 973 check_aggregate:    proc(pt);
 974 
 975 /* check_aggregate makes sure that aggregate temporaries get allocated
 976    outside of the loop in which they might appear */
 977 
 978 dcl            (p,pt,s) ptr;
 979 dcl            i fixed bin;
 980 dcl            op_code bit(9) aligned;
 981 
 982                p = pt;
 983                if p = null then return;
 984                if p -> node.type ^= operator_node then return;
 985 
 986                op_code = p -> operator.op_code;
 987 
 988                if op_code = loop
 989                then do;
 990                     call check_aggregate((p -> operand(1)));
 991                     return;
 992                     end;
 993 
 994                if op_code = join
 995                then do;
 996                     do i = 1 to p -> operator.number;
 997                          call check_aggregate((p -> operand(i)));
 998                          end;
 999                     return;
1000                     end;
1001 
1002                if p -> operator.number = 0 then return;
1003                if p -> operand(1) = null then return;
1004                p = p -> operand(1);
1005                if p -> node.type ^= reference_node then return;
1006                s = p -> reference.symbol;
1007                if s -> node.type ^= symbol_node then return;
1008 
1009                if s -> symbol.temporary
1010                then if s -> symbol.member | s -> symbol.dimensioned | s -> symbol.structure | s -> symbol.arg_descriptor
1011                     then do;
1012                          do  while(s -> symbol.father ^= null);
1013                               s = s -> symbol.father;
1014                               end;
1015 
1016                          if s -> symbol.initial = null
1017                               then call stack_temp$assign_aggregate(s);
1018                          end;
1019 
1020                end /* check_aggregate */;
1021 ^L
1022 can_do_andnot: proc(p_o) returns(bit(1) aligned);
1023 
1024 /* Sees whether a = a & ^ b; can be done in one instruction. */
1025 
1026 dcl            (o,p_o) ptr;   /* operator which might be not_bits */
1027 
1028 dcl            p2 ptr;
1029 dcl            useless bit(1) aligned;
1030 
1031                o = p_o;
1032 
1033                if op_code = and_bits
1034                 & o -> operator.op_code = not_bits
1035                 & o -> operand(1) -> reference.ref_count <= 1
1036                 & ^ o -> operand(1) -> reference.evaluated
1037                then do;
1038                     p2 = o -> operand(2);
1039 
1040                     if p2 -> node.type = reference_node
1041                     then do;
1042                          p2 = prepare_operand(p2,0,useless);          /* set reference.aliasable */
1043                          p2 -> reference.data_type = 0;               /* for future prepare_operand call */
1044 
1045                          if overlaps(rand(1),p2)
1046                               then return("0"b);
1047                          end;
1048 
1049                     return("1"b);
1050                     end;
1051 
1052                return("0"b);
1053 
1054                end /* can_do_andnot */;
1055 end;