THIS FILE IS DAMAGED COMPILATION LISTING OF SEGMENT fort_optimizing_cg Compiled by: Multics PL/I Compiler, Release 32f, of October 9, 1989 Compiled at: Adv Computing Technology Centre Compiled on: 05/30/90 1534.7 mdt Wed Options: optimize map 1 /****^ ********************************************************* 2* * * 3* * Copyright, (C) BULL HN Information Systems Inc., 1990 * 4* * * 5* * Copyright, (C) Honeywell Limited, 1983 * 6* * * 7* * Copyright (c) 1972 by Massachusetts Institute of * 8* * Technology and Honeywell Information Systems, Inc. * 9* * * 10* ********************************************************* */ 11 12 13 14 15 /****^ HISTORY COMMENTS: 16* 1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter), 17* install(86-07-28,MR12.0-1105): 18* Fix fortran bugs 430, 449, 452, 455, 460, 463, and 492. 19* 2) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), 20* install(86-07-28,MR12.0-1105): 21* Fix fortran bugs 411, 425, and 473. 22* 3) change(86-10-17,Ginter), approve(86-10-17,MCR7556), audit(86-10-22,Huen), 23* install(86-11-13,MR12.0-1216): 24* Fixed fortran bugs 496 and 502. 25* 4) change(90-04-27,Huen), approve(90-04-27,MCR8155), audit(90-05-16,Gray), 26* install(90-05-30,MR12.4-1011): 27* ft_508 : Generate correct code for index intrinsic on a substring of a 28* static character variable. 29* END HISTORY COMMENTS */ 30 31 32 /* format: style4,delnl,insnl,^ifthendo,indnoniterend,inditerdo,indend,^indproc,indcom,declareind5 */ 33 fort_optimizing_cg: 34 procedure (p1, p2); 35 36 dcl (p1, p2, shared_struc_ptr, cg_struc_ptr) pointer; 37 dcl (object_base, operand_base, polish_base, relocation_base, quadruple_base, opt_base) pointer; 38 dcl (object_max_len, operand_max_len, polish_max_len, opt_max_len) fixed binary (19); 39 1 1 /* BEGIN fort_nodes.incl.pl1 */ 1 2 1 3 1 4 1 5 /****^ HISTORY COMMENTS: 1 6* 1) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), 1 7* install(86-07-28,MR12.0-1105): 1 8* Fix fortran bug 473. 1 9* 2) change(88-04-28,RWaters), approve(88-04-28,MCR7875), audit(88-07-13,Huen), 1 10* install(88-11-10,MR12.2-1209): 1 11* Implement SCP 6339: Allow character variable to be up to 128K-1 (131071) 1 12* character long. 1 13* END HISTORY COMMENTS */ 1 14 1 15 1 16 /* Written: June 1976 by David Levin and Richard Barnes 1 17* 1 18*Modified: 1 19* Feb 24 1977 by G. Chang for the optimizer 1 20* Sept 12, 1977 by R. Barnes for the loop optimizer 1 21* Nov 16, 1977 by D. Levin to add machine state node for loop optimizer 1 22* Oct 09 1978 by P Smee for larger common and arrays. 1 23* Dec 05 1978 by P Smee for %options statement. 1 24* Jan 17 1979 by R Barnes for machine_state.value_in_xr 1 25* May 23 1979 by P Smee to add source.line_number 1 26* July 19 1979 by R Barnes for char mode changes 1 27* Sept 17 1979 by R Barnes for register optimizer changes 1 28* Oct 3 1979 by C R Davis for new EAQ management scheme. 1 29* 29 Oct 1979 by C R Davis for machine_state.eaq.reserved. 1 30* 3 Nov 1979 by R. Barnes for pointer node and to change 1 31* machine_state.next from a fixed bin to a pointer. 1 32* 18 Dec 1979 by R. Barnes for loop_ref_count to finalize 1 33* changes for the register optimizer. 1 34* 17 Dec 1979 by C R Davis for symbol.descriptor 1 35* 22 Dec 1979 by R. Barnes to remove in_list. 1 36* 22 Jan 1980 by P E Smee to try for long char arrays. 1 37* 23 Jan 1980 by C R Davis to fix bugs with yesterday's changes. 1 38* 4 Mar 1980 by C R Davis to rename node.multi_position to 1 39* node.stack_indirect, and to add machine_state.stack_extended 1 40* and machine_state.last_dynamic_temp. 1 41* 5 Jun 1980 by M E Presser to alter arg_desc node for use 1 42* in stack-extensions and arg-descriptor generation. 1 43* 16 July 1980 by C R Davis for symbol.variable_arglist. 1 44* 8 Jan 81 by M E Presser for label.not_referencable 1 45* 17 Feb 1981 by C R Davis for new dimension node layout. 1 46* 11 March 1981 by MEP for dimension.assumed_size 1 47* 3 May 1982 by TO to add star_extent_function to subprogram node. 1 48* Mod 1 25 August 1982 by TO to add VLA_chain and LA_chain to subprogram node. 1 49* Mod 1 2 September 1982 by TO to add 5 more entries to storage_info in 1 50* the subprogram node (13-17), and to add VLA and LA bits to the 1 51* symbol node. 1 52* Mod 1 2 September 1982 by TO move fields around in nodes to get correct 1 53* 24 (really 35) bit fields and still maintain mapping between 1 54* node, temporary, and array_ref (others limit to word 6 like node.) 1 55* 19 Jun 83, HH - 145: Add 'branched_to', 'ends_do_loop' & 'loop_end' 1 56* to 'label' node. 1 57* 19 Feb 86, BW & AG - 473.a: Add 'VLA' to 'arg_desc' node. 1 58*END Modifications */ 1 59 1 60 1 61 /* GENERAL NODE TEMPLATE */ 1 62 1 63 dcl 1 node aligned based structure, 1 64 1 65 /* WORD 1 */ 1 66 1 67 2 node_type fixed bin (4) unaligned, 1 68 2 data_type fixed bin (4) unaligned unsigned, 1 69 2 operand_type fixed bin (4) unaligned, 1 70 1 71 2 addressing_bits unaligned structure, 1 72 3 is_addressable bit (1), 1 73 3 value_in, 1 74 4 eaq bit (1), 1 75 4 x bit (1), 1 76 3 allocated bit (1), 1 77 3 needs_pointer bit (1), 1 78 3 stack_indirect bit (1), 1 79 3 large_address bit (1), 1 80 3 address_in_base bit (1), 1 81 3 dont_update bit (1), /* for optimizer */ 1 82 3 not_in_storage bit (1), /* for optimizer */ 1 83 3 globally_assigned bit (1), /* for optimizer */ 1 84 1 85 2 bits unaligned structure, 1 86 3 standard_bits, 1 87 4 allocate bit (1), 1 88 4 set bit (1), 1 89 4 referenced bit (1), 1 90 4 passed_as_arg bit (1), 1 91 1 92 3 fill bit (7), /* These bits may be used by individual nodes. */ 1 93 1 94 /* WORD 2 */ 1 95 1 96 2 address aligned structure, 1 97 3 base bit (3) unaligned, /* For labels and constants, base and offset are */ 1 98 3 offset fixed bin (14) unaligned, /* combined to: fixed bin (18) unsigned unaligned. */ 1 99 3 char_num fixed bin (2) unaligned unsigned, 1 100 3 bit_num fixed bin (4) unaligned unsigned, 1 101 3 fill bit (4) unaligned, 1 102 3 inhibit bit (1) unaligned, 1 103 3 ext_base bit (1) unaligned, 1 104 3 tag bit (6) unaligned, 1 105 1 106 /* WORD 3 */ 1 107 1 108 2 units fixed bin (3) unaligned unsigned, 1 109 2 fill bit (3) unaligned, /* already used in symbol node */ 1 110 2 reloc_hold bit (6) unaligned, 1 111 2 reloc bit (6) unaligned, 1 112 2 addr_hold bit (18) unaligned, 1 113 1 114 /* WORD 4. Must not change for constant, char_constant, header, label, or symbol nodes. */ 1 115 1 116 2 next fixed bin (18) unsigned unaligned, 1 117 2 hash_chain fixed bin (18) unsigned unaligned, /* No hash chain for header nodes. */ 1 118 1 119 /* WORD 5 */ 1 120 1 121 2 pad fixed bin (18) unsigned unaligned, 1 122 2 loop_ref_count fixed bin (17) unaligned, /* Only for symbols and temporaries. */ 1 123 1 124 /* WORD 6 */ 1 125 1 126 2 location fixed bin (24) aligned; /* Only for array refs, symbols, temporaries, and headers. */ 1 127 1 128 /* ARG DESCRIPTOR NODE */ 1 129 1 130 dcl 1 arg_desc based aligned, 1 131 1 132 /* WORD 1 */ 1 133 1 134 2 node_type fixed bin (4) unaligned, 1 135 2 n_args fixed bin (12) unaligned, 1 136 2 pad bit (18) unaligned, 1 137 1 138 /* WORDS 2 - N_ARGS + 1 */ 1 139 1 140 2 arg(num_args refer(n_args)) aligned, 1 141 3 data_type fixed bin (4) unaligned unsigned, 1 142 3 must_be unaligned, 1 143 4 array bit (1) unaligned, 1 144 4 scalar bit (1) unaligned, 1 145 4 VLA bit (1) unaligned, 1 146 3 star_extents bit (1) unaligned, 1 147 3 pad bit (9) unaligned, 1 148 3 symbol fixed bin (18) unaligned; 1 149 1 150 dcl num_args fixed bin; 1 151 1 152 1 153 /* ARRAY REF NODE -- Must be same size as TEMPORARY NODE. */ 1 154 1 155 dcl 1 array_ref aligned based structure, 1 156 1 157 /* WORD 1 */ 1 158 1 159 2 node_type fixed bin (4) unaligned, 1 160 2 data_type fixed bin (4) unaligned unsigned, 1 161 2 operand_type fixed bin (4) unaligned, 1 162 1 163 2 addressing_bits unaligned structure, 1 164 3 is_addressable bit (1), 1 165 3 value_in, 1 166 4 eaq bit (1), 1 167 4 x bit (1), 1 168 3 allocated bit (1), 1 169 3 needs_pointer bit (1), 1 170 3 stack_indirect bit (1), 1 171 3 large_address bit (1), 1 172 3 address_in_base bit (1), 1 173 3 dont_update bit (1), /* for optimizer */ 1 174 3 not_in_storage bit (1), /* for optimizer */ 1 175 3 globally_assigned bit (1), /* for optimizer */ 1 176 1 177 2 bits unaligned structure, 1 178 3 standard_bits, 1 179 4 allocate bit (1), 1 180 4 set bit (1), 1 181 4 referenced bit (1), 1 182 4 passed_as_arg bit (1), 1 183 1 184 3 variable_length bit (1), 1 185 1 186 3 variable_offset bit (1), 1 187 1 188 3 invariant bit (1), /* must line up with temporary node */ 1 189 3 irreducible bit (1), /* .. */ 1 190 3 used_across_loops bit (1), /* .. */ 1 191 1 192 3 large_offset bit (1), 1 193 1 194 3 has_address bit (1), 1 195 1 196 /* WORD 2 */ 1 197 1 198 2 address aligned structure, 1 199 3 base bit (3) unaligned, 1 200 3 offset fixed bin (14) unaligned, 1 201 3 char_num fixed bin (2) unaligned unsigned, 1 202 3 bit_num fixed bin (4) unaligned unsigned, 1 203 3 fill bit (4) unaligned, 1 204 3 inhibit bit (1) unaligned, 1 205 3 ext_base bit (1) unaligned, 1 206 3 tag bit (6) unaligned, 1 207 1 208 /* WORD 3 */ 1 209 1 210 2 units fixed bin (3) unaligned unsigned, 1 211 2 fill bit (3) unaligned, 1 212 2 reloc_hold bit (6) unaligned, 1 213 2 reloc bit (6) unaligned, 1 214 2 addr_hold bit (18) unaligned, 1 215 1 216 /* WORD 4 */ 1 217 1 218 2 next fixed bin (18) unsigned unaligned, 1 219 2 loop_end_fu_pos fixed bin (17) unaligned, /* must overlay temporary.loop_end_fu_pos */ 1 220 1 221 /* WORD 5 */ 1 222 1 223 2 pad fixed bin (18) unsigned unaligned, 1 224 2 v_offset fixed bin (18) unsigned unaligned, 1 225 1 226 /* WORD 6 */ 1 227 1 228 2 location fixed bin (24) aligned, 1 229 1 230 /* WORD 7 */ 1 231 1 232 2 ref_count fixed bin (17) unaligned, /* must overlay temporary.ref_count */ 1 233 2 output_by fixed bin (18) unsigned unal, /* must overlay temporary.output_by */ 1 234 1 235 /* WORD 8 */ 1 236 1 237 2 length fixed bin (24) aligned, 1 238 1 239 /* WORD 9 */ 1 240 1 241 2 start_input_to fixed bin (18) unsigned unal, /* must overlay temporary.start_input_to */ 1 242 2 end_input_to fixed bin (18) unsigned unal, /* must overlay temporary.end_input_to */ 1 243 1 244 /* WORD 10 */ 1 245 1 246 2 ref_count_copy fixed bin (17) unaligned, /* must overlay temporary.ref_count_copy */ 1 247 2 parent fixed bin (18) unsigned unaligned, 1 248 1 249 /* WORD 11 */ 1 250 1 251 2 unused fixed bin (24) aligned; /* Pad to size of 'temporary'. */ 1 252 1 253 1 254 /* CONSTANT NODE */ 1 255 1 256 dcl 1 constant aligned based structure, 1 257 1 258 /* WORD 1 */ 1 259 1 260 2 node_type fixed bin (4) unaligned, 1 261 2 data_type fixed bin (4) unaligned unsigned, 1 262 2 operand_type fixed bin (4) unaligned, 1 263 1 264 2 addressing_bits unaligned structure, 1 265 3 is_addressable bit (1), 1 266 3 value_in, 1 267 4 eaq bit (1), 1 268 4 x bit (1), 1 269 3 allocated bit (1), 1 270 3 needs_pointer bit (1), 1 271 3 stack_indirect bit (1), 1 272 3 large_address bit (1), 1 273 3 address_in_base bit (1), 1 274 3 dont_update bit (1), /* for optimizer */ 1 275 3 not_in_storage bit (1), /* for optimizer */ 1 276 3 globally_assigned bit (1), /* for optimizer */ 1 277 1 278 2 bits unaligned structure, 1 279 3 standard_bits, 1 280 4 allocate bit (1), 1 281 4 set bit (1), 1 282 4 referenced bit (1), 1 283 4 passed_as_arg bit (1), 1 284 1 285 3 fill bit (7), 1 286 1 287 /* WORD 2 */ 1 288 1 289 2 address aligned structure, 1 290 3 location fixed bin (18) unsigned unaligned, 1 291 3 op bit (10) unaligned, 1 292 3 inhibit bit (1) unaligned, 1 293 3 ext_base bit (1) unaligned, 1 294 3 tag bit (6) unaligned, 1 295 1 296 /* WORD 3 */ 1 297 1 298 2 units fixed bin (3) unaligned unsigned, 1 299 2 fill bit (3) unaligned, 1 300 2 reloc_hold bit (6) unaligned, 1 301 2 reloc bit (6) unaligned, 1 302 2 addr_hold bit (18) unaligned, 1 303 1 304 /* WORD 4 */ 1 305 1 306 2 next_constant fixed bin (18) unsigned unaligned, 1 307 2 hash_chain fixed bin (18) unsigned unaligned, 1 308 1 309 /* WORDS 5 & 6 */ 1 310 1 311 2 value bit (72) aligned; 1 312 1 313 1 314 /* CHARACTER CONSTANT NODE */ 1 315 1 316 dcl 1 char_constant aligned based structure, 1 317 1 318 /* WORD 1 */ 1 319 1 320 2 node_type fixed bin (4) unaligned, 1 321 2 data_type fixed bin (4) unaligned unsigned, 1 322 2 operand_type fixed bin (4) unaligned, 1 323 1 324 2 addressing_bits unaligned structure, 1 325 3 is_addressable bit (1), 1 326 3 value_in, 1 327 4 eaq bit (1), 1 328 4 x bit (1), 1 329 3 allocated bit (1), 1 330 3 needs_pointer bit (1), 1 331 3 stack_indirect bit (1), 1 332 3 large_address bit (1), 1 333 3 address_in_base bit (1), 1 334 3 dont_update bit (1), /* for optimizer */ 1 335 3 not_in_storage bit (1), /* for optimizer */ 1 336 3 globally_assigned bit (1), /* for optimizer */ 1 337 1 338 2 bits unaligned structure, 1 339 3 standard_bits, 1 340 4 allocate bit (1), 1 341 4 set bit (1), 1 342 4 referenced bit (1), 1 343 4 passed_as_arg bit (1), 1 344 1 345 3 no_value_stored bit (1), 1 346 1 347 3 fill bit (6), 1 348 1 349 /* WORD 2 */ 1 350 1 351 2 address aligned structure, 1 352 3 location fixed bin (18) unsigned unaligned, 1 353 3 char_num fixed bin (2) unaligned unsigned, 1 354 3 bit_num fixed bin (4) unaligned unsigned, 1 355 3 fill bit (4) unaligned, 1 356 3 inhibit bit (1) unaligned, 1 357 3 ext_base bit (1) unaligned, 1 358 3 tag bit (6) unaligned, 1 359 1 360 /* WORD 3 */ 1 361 1 362 2 units fixed bin (3) unaligned unsigned, 1 363 2 fill bit (3) unaligned, 1 364 2 reloc_hold bit (6) unaligned, 1 365 2 reloc bit (6) unaligned, 1 366 2 addr_hold bit (18) unaligned, 1 367 1 368 /* WORD 4 */ 1 369 1 370 2 next_constant fixed bin (18) unsigned unaligned, 1 371 2 hash_chain fixed bin (18) unsigned unaligned, 1 372 1 373 /* WORDS 5 thru n */ 1 374 1 375 2 length fixed bin (18) unsigned unaligned, 1 376 2 value char(char_constant_length refer(char_constant.length)) unaligned; 1 377 1 378 dcl char_constant_length fixed bin (18) unsigned; 1 379 1 380 1 381 /* DIMENSION NODE */ 1 382 1 383 dcl 1 dimension aligned based structure, 1 384 1 385 /* WORD 1 */ 1 386 1 387 2 node_type fixed bin (4) unaligned, /* The only field in common with other nodes */ 1 388 1 389 2 number_of_dims fixed bin (3) unaligned, /* Number of dimensions */ 1 390 1 391 2 v_bound (7) unaligned, /* Variable bound info - up to 7 dims. */ 1 392 3 lower bit (1) unaligned, /* On if lower bound is variable */ 1 393 3 upper bit (1) unaligned, /* On if upper bound is variable */ 1 394 1 395 2 has_virtual_origin bit (1) unaligned, /* On if virtual_origin is valid */ 1 396 2 has_array_size bit (1) unaligned, /* On if array_size is valid */ 1 397 2 has_dim_sizes bit (1) unaligned, /* On if dim.size (*) is valid */ 1 398 1 399 2 variable_virtual_origin bit (1) unaligned, /* On if virtual_origin is variable */ 1 400 2 variable_array_size bit (1) unaligned, /* On if array_size is variable */ 1 401 2 assumed_size bit (1) unaligned, /* On if array has assumed size */ 1 402 1 403 2 fill bit (7) unaligned, 1 404 1 405 /* WORD 2 */ 1 406 1 407 2 virtual_origin fixed bin (24) aligned, 1 408 1 409 /* WORD 3 */ 1 410 1 411 2 element_count fixed bin (24) aligned, 1 412 1 413 /* WORD 4 */ 1 414 1 415 2 array_size fixed bin (24) aligned, /* Expressed in symbol.units */ 1 416 1 417 /* WORD 5 */ 1 418 1 419 2 VLA_base_addressor fixed bin (18) aligned, 1 420 1 421 /* WORDS 6 - n (max = 26) */ 1 422 1 423 2 dim (num_dims refer (dimension.number_of_dims)) aligned, 1 424 1 425 3 lower_bound fixed bin (24) aligned, /* Lower bound of this dimension */ 1 426 1 427 3 upper_bound fixed bin (24) aligned, /* Upper bound of this dimension */ 1 428 1 429 3 size fixed bin (24) aligned; /* No. of elements in this dimension */ 1 430 1 431 dcl num_dims fixed bin (3); 1 432 1 433 1 434 /* HEADER NODE */ 1 435 1 436 dcl 1 header aligned based structure, 1 437 1 438 /* WORD 1 */ 1 439 1 440 2 node_type fixed bin (4) unaligned, 1 441 2 data_type fixed bin (4) unaligned unsigned, 1 442 2 operand_type fixed bin (4) unaligned, 1 443 1 444 2 addressing_bits unaligned structure, 1 445 3 is_addressable bit (1), 1 446 3 value_in, 1 447 4 eaq bit (1), 1 448 4 x bit (1), 1 449 3 allocated bit (1), 1 450 3 needs_pointer bit (1), 1 451 3 stack_indirect bit (1), 1 452 3 large_address bit (1), 1 453 3 address_in_base bit (1), 1 454 3 dont_update bit (1), /* for optimizer */ 1 455 3 not_in_storage bit (1), /* for optimizer */ 1 456 3 globally_assigned bit (1), /* for optimizer */ 1 457 1 458 2 bits unaligned structure, 1 459 3 storage_info, 1 460 4 standard_bits, 1 461 5 allocate bit (1), 1 462 5 set bit (1), 1 463 5 referenced bit (1), 1 464 5 passed_as_arg bit (1), 1 465 4 initialed bit (1), /* On if any member has initial attribute. */ 1 466 1 467 3 alignment structure unaligned, 1 468 4 even bit (1), 1 469 4 odd bit (1), 1 470 4 character bit (1), 1 471 1 472 3 storage_class structure unaligned, 1 473 4 automatic bit (1), 1 474 4 static bit (1), 1 475 4 in_common bit (1), 1 476 1 477 /* WORD 2 */ 1 478 1 479 2 address aligned structure, 1 480 3 base bit (3) unaligned, 1 481 3 offset fixed bin (14) unaligned, 1 482 3 char_num fixed bin (2) unaligned unsigned, 1 483 3 bit_num fixed bin (4) unaligned unsigned, 1 484 3 fill bit (4) unaligned, 1 485 3 inhibit bit (1) unaligned, 1 486 3 ext_base bit (1) unaligned, 1 487 3 tag bit (6) unaligned, 1 488 1 489 /* WORD 3 */ 1 490 1 491 2 units fixed bin (3) unaligned unsigned, 1 492 2 VLA bit (1) unaligned, /* chain for VLA's */ 1 493 2 LA bit (1) unaligned, /* chain for LA's */ 1 494 2 fill bit (1) unaligned, 1 495 2 reloc_hold bit (6) unaligned, 1 496 2 reloc bit (6) unaligned, 1 497 2 addr_hold bit (18) unaligned, 1 498 1 499 /* WORD 4 */ 1 500 1 501 2 next_header fixed bin (18) unsigned unaligned, 1 502 2 first_element fixed bin (18) unsigned unaligned, 1 503 1 504 /* WORD 5 */ 1 505 1 506 2 last_element fixed bin (18) unsigned unaligned, 1 507 2 name_length fixed bin (17) unaligned, 1 508 1 509 /* WORD 6 */ 1 510 1 511 2 location fixed bin (24) aligned, 1 512 1 513 /* WORD 7 */ 1 514 1 515 2 length fixed bin (24) aligned, 1 516 1 517 /* WORD 8 */ 1 518 1 519 2 VLA_base_addressor fixed bin (18) aligned, 1 520 1 521 /* WORDS 9 - n. This field is variable in length. Its length is zero for equivalence groups. */ 1 522 1 523 2 block_name char(allocate_symbol_name refer (header.name_length)) aligned; 1 524 1 525 dcl allocate_symbol_name fixed bin; 1 526 1 527 1 528 /* LABEL NODE */ 1 529 1 530 dcl 1 label aligned based structure, 1 531 1 532 /* WORD 1 */ 1 533 1 534 2 node_type fixed bin (4) unaligned, 1 535 2 data_type fixed bin (4) unaligned unsigned, 1 536 2 operand_type fixed bin (4) unaligned, 1 537 1 538 2 addressing_bits unaligned structure, 1 539 3 is_addressable bit (1), 1 540 3 value_in, 1 541 4 eaq bit (1), 1 542 4 x bit (1), 1 543 3 allocated bit (1), 1 544 3 needs_pointer bit (1), 1 545 3 stack_indirect bit (1), 1 546 3 large_address bit (1), 1 547 3 address_in_base bit (1), 1 548 3 dont_update bit (1), /* for optimizer */ 1 549 3 not_in_storage bit (1), /* for optimizer */ 1 550 3 globally_assigned bit (1), /* for optimizer */ 1 551 1 552 2 bits unaligned structure, 1 553 3 storage_info, 1 554 4 standard_bits, 1 555 5 allocate bit (1), 1 556 5 set bit (1), 1 557 5 referenced bit (1), 1 558 5 passed_as_arg bit (1), 1 559 4 referenced_executable bit (1), 1 560 1 561 3 usage, /* Label is on a non-executable stmnt if both bits are ON. */ 1 562 4 format bit (1), 1 563 4 executable bit (1), 1 564 1 565 3 restore_prs bit (1), 1 566 3 not_referencable bit (1), 1 567 3 branched_to bit (1), 1 568 3 ends_do_loop bit (1), 1 569 1 570 /* WORD 2 */ 1 571 1 572 2 address aligned structure, 1 573 3 location fixed bin (18) unsigned unaligned, 1 574 3 op bit (10) unaligned, 1 575 3 inhibit bit (1) unaligned, 1 576 3 ext_base bit (1) unaligned, 1 577 3 tag bit (6) unaligned, 1 578 1 579 /* WORD 3 */ 1 580 1 581 2 units fixed bin (3) unaligned unsigned, 1 582 2 fill bit (3) unaligned, 1 583 2 reloc_hold bit (6) unaligned, 1 584 2 reloc bit (6) unaligned, 1 585 2 addr_hold bit (18) unaligned, 1 586 1 587 /* WORD 4 */ 1 588 1 589 2 next_label fixed bin (18) unsigned unaligned, 1 590 2 hash_chain fixed bin (18) unsigned unaligned, 1 591 1 592 /* WORD 5 */ 1 593 1 594 2 format_var fixed bin (18) unsigned unaligned, 1 595 2 name fixed bin (17) unaligned, 1 596 1 597 /* WORD 6 */ 1 598 1 599 2 statement fixed bin (18) unsigned unaligned, 1 600 2 loop_end fixed bin (18) unsigned unaligned; 1 601 1 602 1 603 /* LIBRARY NODE */ 1 604 1 605 dcl 1 library aligned based structure, 1 606 1 607 /* WORD 1 */ 1 608 1 609 2 node_type fixed bin (4) unaligned, /* The only field in common with the other nodes. */ 1 610 2 fill bit (13) unaligned, 1 611 2 next_library_node fixed bin (18) unsigned unaligned, 1 612 1 613 /* WORD 2 */ 1 614 1 615 2 character_operand fixed bin (18) unsigned aligned; 1 616 1 617 1 618 /* MACHINE_STATE NODE */ 1 619 1 620 dcl 1 machine_state aligned based structure, 1 621 1 622 /* WORD 1 */ 1 623 1 624 2 node_type fixed bin (4) unal, 1 625 2 pad bit (31) unal, 1 626 1 627 /* WORD 2 */ 1 628 1 629 2 next pointer unaligned, 1 630 1 631 /* WORDS 3-104 */ 1 632 1 633 2 ms aligned, 1 634 1 635 3 eaq (4), /* One for each of the A, Q, EAQ, and IND */ 1 636 4 name fixed bin, 1 637 4 number fixed bin, 1 638 4 variable(4) fixed bin (18), 1 639 4 reserved bit (1) aligned, 1 640 3 rounded bit (1) aligned, 1 641 3 indicators_valid fixed bin (18), 1 642 1 643 3 value_in_xr bit (1) aligned, 1 644 1 645 3 index_regs(0:7), 1 646 4 bits structure unaligned, 1 647 5 global bit (1), 1 648 5 reserved bit (1), 1 649 5 mbz bit (34), 1 650 4 type fixed bin (18), 1 651 4 variable fixed bin (18), 1 652 4 used fixed bin (18), 1 653 4 mbz fixed bin (18), 1 654 1 655 3 address_in_base bit (1) aligned, 1 656 1 657 3 base_regs(0:7), 1 658 4 bits structure unaligned, 1 659 5 global bit (1), 1 660 5 reserved bit (1), 1 661 5 mbz bit (34), 1 662 4 type fixed bin (18), 1 663 4 variable fixed bin (18), 1 664 4 used fixed bin (18), 1 665 4 offset fixed bin (18), 1 666 1 667 3 stack_extended bit (1) aligned, 1 668 3 last_dynamic_temp fixed bin (18); 1 669 1 670 /* POINTER NODE */ 1 671 1 672 dcl 1 pointer aligned based structure, 1 673 1 674 /* WORD 1 */ 1 675 1 676 2 node_type fixed bin (4) unaligned, 1 677 2 pad bit (4) unaligned, 1 678 2 code fixed bin (9) unaligned unsigned, 1 679 2 variable fixed bin (18) unaligned unsigned, 1 680 1 681 /* WORD 2 */ 1 682 1 683 2 offset fixed bin (18) unaligned unsigned, 1 684 2 count fixed bin (18) unaligned unsigned, 1 685 1 686 /* WORD 3 */ 1 687 1 688 2 hash_chain fixed bin (18) aligned; 1 689 1 690 1 691 /* SOURCE NODE */ 1 692 1 693 dcl 1 source aligned based structure, 1 694 1 695 /* WORD 1 */ 1 696 1 697 2 node_type fixed bin (4) unal, 1 698 2 pad bit (13) unal, 1 699 2 line_number fixed bin (17) unaligned, 1 700 1 701 /* WORD 2 */ 1 702 1 703 2 uid bit (36) aligned, 1 704 1 705 /* WORDS 3 & 4 */ 1 706 1 707 2 dtm fixed bin (71) unaligned, 1 708 1 709 /* WORD 5 */ 1 710 1 711 2 next fixed bin (18) unsigned unaligned, 1 712 2 initial_subprogram fixed bin (18) unsigned unaligned, 1 713 1 714 /* WORDS 6 - ? (depends on length of pathname) */ 1 715 1 716 2 pathname char(256) varying; 1 717 1 718 1 719 /* STATEMENT NODE - This node only appears in the polish. */ 1 720 1 721 dcl 1 statement aligned based structure, 1 722 1 723 /* WORD 1 */ 1 724 1 725 2 op_code fixed bin aligned, /* Always equal to "stat_op". */ 1 726 1 727 /* WORD 2 */ 1 728 1 729 2 next bit (18) unaligned, /* "0"b = no next stmnt */ 1 730 2 location bit (18) unaligned, /* (18)"1"b = no text */ 1 731 1 732 /* WORD 3 */ 1 733 1 734 2 source_id structure unaligned, 1 735 3 file fixed bin (8) unsigned, /* 0 = first file */ 1 736 3 line bit (14), 1 737 3 statement bit (5), /* 1 = first statement */ 1 738 1 739 2 length bit (9) unaligned, 1 740 1 741 /* WORD 4 */ 1 742 1 743 2 bits structure unaligned, 1 744 3 put_in_map bit (1) unaligned, 1 745 3 put_in_profile bit (1) unaligned, 1 746 3 pad bit (7) unaligned, 1 747 1 748 2 start fixed bin (26) unaligned; 1 749 1 750 1 751 /* SUBPROGRAM NODE */ 1 752 1 753 dcl 1 subprogram aligned based structure, 1 754 1 755 /* WORD 1 */ 1 756 1 757 2 node_type fixed bin (4) unaligned, /* The only field in common with the other nodes. */ 1 758 2 subprogram_type fixed bin (3) unaligned, 1 759 2 default_is unaligned, 1 760 3 auto bit (1), 1 761 3 static bit (1), 1 762 2 need_PS bit (1) unaligned, 1 763 2 need_prologue bit (1) unaligned, 1 764 2 multiple_entry bit (1) unaligned, 1 765 2 namelist_used bit (1) unaligned, 1 766 2 has_parameters bit (1) unaligned, 1 767 2 star_extent_function bit (1) unaligned, 1 768 2 fill bit (1) unaligned, 1 769 1 770 2 symbol fixed bin (18) unsigned unaligned, /* symbol node for subprogram name */ 1 771 1 772 /* WORD 2 */ 1 773 1 774 2 previous_subprogram fixed bin (18) unsigned unaligned, 1 775 2 next_subprogram fixed bin (18) unsigned unaligned, 1 776 1 777 /* WORD 3 */ 1 778 1 779 2 common_chain fixed bin (18) unsigned unaligned, 1 780 2 equiv_chain fixed bin (18) unsigned unaligned, 1 781 1 782 /* WORD 4 */ 1 783 1 784 2 first_symbol fixed bin (18) unsigned unaligned, 1 785 2 last_symbol fixed bin (18) unsigned unaligned, 1 786 1 787 /* WORD 5 */ 1 788 1 789 2 first_label fixed bin (18) unsigned unaligned, 1 790 2 last_label fixed bin (18) unsigned unaligned, 1 791 1 792 /* WORD 6 */ 1 793 1 794 2 first_polish fixed bin (18) unsigned unaligned, 1 795 2 last_polish fixed bin (18) unsigned unaligned, 1 796 1 797 /* WORD 7 */ 1 798 1 799 2 map unaligned, 1 800 3 first fixed bin (18) unsigned unaligned, 1 801 3 last fixed bin (18) unsigned unaligned, 1 802 1 803 /* WORD 8 */ 1 804 1 805 2 entry_info fixed bin (18) unsigned unaligned, 1 806 2 runtime fixed bin (18) unsigned unaligned, 1 807 1 808 /* WORD 9 */ 1 809 1 810 2 first_quad fixed bin (18) unsigned unaligned, 1 811 2 last_quad fixed bin (18) unsigned unaligned, 1 812 1 813 /* WORD 10 */ 1 814 1 815 2 options aligned like fortran_options, 1 816 1 817 /* WORDS 11 - 44 */ 1 818 1 819 2 storage_info(17) aligned, 1 820 3 first fixed bin (18) unsigned unaligned, 1 821 3 last fixed bin (18) unsigned unaligned, 1 822 3 next_loc fixed bin (18) aligned, 1 823 1 824 /* WORD 45 */ 1 825 1 826 2 loop_vector_p pointer unaligned, 1 827 1 828 /* WORD 46 */ 1 829 1 830 2 n_loops fixed bin (18) unsigned unaligned, 1 831 2 max_operators fixed bin (18) unsigned unaligned, 1 832 1 833 /* WORD 47 */ 1 834 1 835 2 VLA_chain fixed bin (18) unsigned unaligned, /* Mod 1 */ 1 836 2 LA_chain fixed bin (18) unsigned unaligned, /* Mod 1 */ 1 837 /* WORD 48 */ 1 838 1 839 2 max_sym fixed bin (18) aligned; 1 840 1 841 1 842 /* SYMBOL NODE */ 1 843 1 844 dcl 1 symbol aligned based structure, 1 845 1 846 /* WORD 1 */ 1 847 1 848 2 node_type fixed bin (4) unaligned, 1 849 2 data_type fixed bin (4) unaligned unsigned, 1 850 2 operand_type fixed bin (4) unaligned, 1 851 1 852 2 addressing_bits unaligned structure, 1 853 3 is_addressable bit (1), 1 854 3 value_in, 1 855 4 eaq bit (1), 1 856 4 x bit (1), 1 857 3 allocated bit (1), 1 858 3 needs_pointer bit (1), 1 859 3 stack_indirect bit (1), 1 860 3 large_address bit (1), 1 861 3 address_in_base bit (1), 1 862 3 dont_update bit (1), /* for optimizer */ 1 863 3 not_in_storage bit (1), /* for optimizer */ 1 864 3 globally_assigned bit (1), /* for optimizer */ 1 865 1 866 2 bits unaligned structure, 1 867 3 storage_info, 1 868 4 standard_bits, 1 869 5 allocate bit (1), 1 870 5 set bit (1), 1 871 5 referenced bit (1), 1 872 5 passed_as_arg bit (1), 1 873 4 initialed bit (1), /* Allows variable to become a constant. */ 1 874 1 875 3 variable_arglist bit (1), 1 876 3 dummy_arg bit (1), 1 877 3 variable_extents bit (1), 1 878 3 needs_descriptors bit (1), 1 879 3 put_in_symtab bit (1), 1 880 3 by_compiler bit (1), 1 881 1 882 /* WORD 2 */ 1 883 1 884 2 address aligned structure, 1 885 3 base bit (3) unaligned, 1 886 3 offset fixed bin (14) unaligned, 1 887 3 char_num fixed bin (2) unaligned unsigned, 1 888 3 bit_num fixed bin (4) unaligned unsigned, 1 889 3 fill bit (4) unaligned, 1 890 3 inhibit bit (1) unaligned, 1 891 3 ext_base bit (1) unaligned, 1 892 3 tag bit (6) unaligned, 1 893 1 894 /* WORD 3 */ 1 895 1 896 2 units fixed bin (3) unaligned unsigned, 1 897 2 aliasable bit (1) unaligned, 1 898 2 has_constant_value bit (1) unaligned, 1 899 2 new_induction_var bit (1) unaligned, 1 900 2 reloc_hold bit (6) unaligned, 1 901 2 reloc bit (6) unaligned, 1 902 2 addr_hold bit (18) unaligned, 1 903 1 904 /* WORD 4 */ 1 905 1 906 2 next_symbol fixed bin (18) unsigned unaligned, 1 907 2 hash_chain fixed bin (18) unsigned unaligned, 1 908 1 909 /* WORD 5 */ 1 910 1 911 2 ext_attributes unaligned structure, 1 912 3 VLA bit (1), /* symbol is Very large Element */ 1 913 3 LA bit (1), /* symbol is Large Element */ 1 914 3 pad bit (18-2), 1 915 1 916 2 loop_ref_count fixed bin (17) unaligned, 1 917 1 918 /* WORD 6 */ 1 919 1 920 2 location fixed bin (24) aligned, 1 921 1 922 /* WORD 7 */ 1 923 1 924 2 v_length fixed bin (18) unsigned unaligned, 1 925 2 general fixed bin (18) unsigned unaligned, 1 926 1 927 /* WORD 8 */ 1 928 1 929 2 parent fixed bin (18) unsigned unaligned, 1 930 2 next_member fixed bin (18) unsigned unaligned, 1 931 1 932 /* WORD 9 */ 1 933 1 934 2 attributes aligned structure, 1 935 3 mode_bits unaligned structure, 1 936 4 char_size fixed bin (20) unsigned, 1 937 4 mode, 1 938 5 integer bit (1), 1 939 5 real bit (1), 1 940 5 double_precision bit (1), 1 941 5 complex bit (1), 1 942 5 logical bit (1), 1 943 5 character bit (1), 1 944 5 label_value bit (1), 1 945 5 entry_value bit (1), 1 946 1 947 3 misc_attributes unaligned structure, 1 948 4 function bit (1), 1 949 4 subroutine bit (1), 1 950 4 entry_point bit (1), 1 951 4 external bit (1), 1 952 4 builtin bit (1), 1 953 4 stmnt_func bit (1), 1 954 4 namelist bit (1), 1 955 4 dimensioned bit (1), 1 956 1 957 /* WORD 10 */ 1 958 1 959 3 storage_class unaligned structure, 1 960 4 automatic bit (1), 1 961 4 static bit (1), 1 962 4 in_common bit (1), 1 963 4 equivalenced bit (1), 1 964 4 parameter bit (1), 1 965 4 constant bit (1), /* If external or entry_point. */ 1 966 4 named_constant bit (1), 1 967 1 968 3 variable bit (1) unaligned, 1 969 3 in_equiv_stmnt bit (1) unaligned, 1 970 3 star_extents bit (1) unaligned, 1 971 3 descriptor bit (1) unaligned, 1 972 2 pad bit (25) unaligned, 1 973 1 974 /* WORD 11 */ 1 975 1 976 2 dimension fixed bin (18) unsigned unaligned, /* Bounds may be added after symbol is declared. */ 1 977 2 initial fixed bin (18) unsigned unaligned, 1 978 1 979 /* WORD 12 */ 1 980 1 981 2 runtime bit (18) unaligned, 1 982 2 name_length fixed bin (17) unaligned, 1 983 1 984 /* WORD 13 */ 1 985 1 986 2 coordinate fixed bin (17) unaligned, /* used by loop optimizer */ 1 987 2 element_size fixed bin (17) unaligned, 1 988 1 989 /* WORD 14 */ 1 990 1 991 2 secondary pointer unaligned, /* used by loop optimizer */ 1 992 1 993 /* WORD 15 */ 1 994 1 995 2 offset fixed bin (24) aligned, 1 996 1 997 /* WORDS 16 - n. This field is variable in length. */ 1 998 1 999 2 name char(allocate_symbol_name refer (symbol.name_length)) aligned; 1 1000 1 1001 1 1002 1 1003 /* TEMPORARY NODE -- Must be same size as ARRAY REF NODE. */ 1 1004 1 1005 dcl 1 temporary aligned based structure, 1 1006 1 1007 /* WORD 1 */ 1 1008 1 1009 2 node_type fixed bin (4) unaligned, 1 1010 2 data_type fixed bin (4) unaligned unsigned, 1 1011 2 operand_type fixed bin (4) unaligned, 1 1012 1 1013 2 addressing_bits unaligned structure, 1 1014 3 is_addressable bit (1), 1 1015 3 value_in, 1 1016 4 eaq bit (1), 1 1017 4 x bit (1), 1 1018 3 allocated bit (1), 1 1019 3 needs_pointer bit (1), 1 1020 3 stack_indirect bit (1), 1 1021 3 large_address bit (1), 1 1022 3 address_in_base bit (1), 1 1023 3 dont_update bit (1), /* for optimizer */ 1 1024 3 not_in_storage bit (1), /* for optimizer */ 1 1025 3 globally_assigned bit (1), /* for optimizer */ 1 1026 1 1027 2 bits unaligned structure, 1 1028 3 standard_bits, 1 1029 4 allocate bit (1), 1 1030 4 set bit (1), 1 1031 4 referenced bit (1), 1 1032 4 passed_as_arg bit (1), 1 1033 1 1034 3 variable_length bit (1), 1 1035 1 1036 3 fill bit (1), /* can be used */ 1 1037 1 1038 3 invariant bit (1), /* must line up with array_ref node */ 1 1039 3 irreducible bit (1), /* .. */ 1 1040 3 used_across_loops bit (1), /* .. */ 1 1041 3 frozen_for_do bit (1), 1 1042 3 used_as_subscript bit (1), 1 1043 1 1044 /* WORD 2 */ 1 1045 1 1046 2 address aligned structure, 1 1047 3 base bit (3) unaligned, 1 1048 3 offset fixed bin (14) unaligned, 1 1049 3 char_num fixed bin (2) unaligned unsigned, 1 1050 3 bit_num fixed bin (4) unaligned unsigned, 1 1051 3 fill bit (4) unaligned, 1 1052 3 inhibit bit (1) unaligned, 1 1053 3 ext_base bit (1) unaligned, 1 1054 3 tag bit (6) unaligned, 1 1055 1 1056 /* WORD 3 */ 1 1057 1 1058 2 units fixed bin (3) unaligned unsigned, 1 1059 2 fill bit (3) unaligned, 1 1060 2 reloc_hold bit (6) unaligned, 1 1061 2 reloc bit (6) unaligned, 1 1062 2 addr_hold bit (18) unaligned, 1 1063 1 1064 /* WORD 4 */ 1 1065 1 1066 2 next fixed bin (18) unsigned unaligned, 1 1067 2 loop_end_fu_pos fixed bin (17) unaligned, /* must overlay array_ref.loop_end_fu_pos */ 1 1068 1 1069 /* WORD 5 */ 1 1070 1 1071 2 pad fixed bin (18) unsigned unaligned, 1 1072 2 loop_ref_count fixed bin (17) unaligned, 1 1073 1 1074 /* WORD 6 */ 1 1075 1 1076 2 location fixed bin (24) aligned, 1 1077 1 1078 /* WORD 7*/ 1 1079 1 1080 2 ref_count fixed bin (17) unaligned, /* must overlay array_ref.ref_count */ 1 1081 2 output_by fixed bin (18) unsigned unal, /* must overlay array_ref.output_by */ 1 1082 1 1083 /* WORD 8 */ 1 1084 1 1085 2 size fixed bin (24) aligned, /* size in words */ 1 1086 1 1087 /* WORD 9 */ 1 1088 1 1089 2 start_input_to fixed bin (18) unsigned unal, /* must overlay array_ref.start_input_to */ 1 1090 2 end_input_to fixed bin (18) unsigned unal, /* must overlay array_ref.end_input_to */ 1 1091 1 1092 /* WORD 10 */ 1 1093 1 1094 2 ref_count_copy fixed bin (17) unaligned, /* must overlay array_ref.ref_count_copy */ 1 1095 2 ms_ref_count fixed bin (17) unaligned, /* counts occurances in saved machine states */ 1 1096 1 1097 /* WORD 11 */ 1 1098 1 1099 2 length fixed bin (24) aligned; /* length in characters */ 1 1100 1 1101 /* END fort_nodes.incl.pl1 */ 40 2 1 /* BEGIN fort_opt_nodes.incl.pl1 */ 2 2 2 3 /* Created: 22 November 1977 by Richard A. Barnes for the optimizing Fortran compiler */ 2 4 2 5 /* Modified: 09 October 1978 by Paul E. Smee for larger common and arrays. 2 6* Modified: 2 June 1979 by RAB to speed up intersection of optimizer 2 7* machine states by adding operator.coordinate and 2 8* flow_unit.is_active_operator 2 9* Modified: 28 June 1979 by RAB to speed up compute_busy_on_exit by 2 10* adding flow_unit.dim_or_alias_or_not_set. 2 11* Modified: 02 July 1979 by RAB to fix 218 by moving loop_end_chain stuff 2 12* to flow_unit node from loop node. 2 13* Modified: 14 August 1979 by RAB to change flow_unit.dim_or_alias_or_not_set 2 14* to flow_unit.always_completely_set. 2 15* Modified: 17 September 1979 by RAB in preparation for register optimizer. 2 16* Modified: 20 September 1979 by RAB for index_value_analysis of register optimizer. 2 17* Modified: 03 November 1979 by RAB for flow_unit.refreshed for register optimizer. 2 18* Modified: 30 November 1979 by RAB to add more info to the loop node 2 19* for the register optimizer. 2 20* Modified: 18 December 1979 by RAB to make remainder of register 2 21* optimizer changes. 2 22* Modified: 17 December 1980 by CRD to add opt_statement.removable. 2 23**/ 2 24 2 25 /* CHAIN (2 words) */ 2 26 2 27 dcl 1 chain based aligned, 2 28 2 next pointer unaligned, 2 29 2 value pointer unaligned; 2 30 2 31 /* EDGE (6 words) */ 2 32 2 33 dcl 1 edge based aligned, 2 34 2 from structure, 2 35 3 value ptr unal, 2 36 3 next ptr unal, 2 37 3 back ptr unal, 2 38 2 to structure, 2 39 3 value ptr unal, 2 40 3 next ptr unal, 2 41 3 back ptr unal; 2 42 2 43 2 44 /* FLOW_UNIT (22 words) */ 2 45 2 46 dcl 1 flow_unit based aligned, 2 47 2 next ptr unal, 2 48 2 back ptr unal, 2 49 2 successors ptr unal, 2 50 2 predecessors ptr unal, 2 51 2 dominator ptr unal, 2 52 2 loop ptr unal, 2 53 2 next_in_loop ptr unal, 2 54 2 loop_end_chain ptr unal, 2 55 2 position fixed bin(17) aligned, 2 56 2 number fixed bin(17) unal, 2 57 2 n_in_loop_end fixed bin(17) unal, 2 58 2 level_number fixed bin(17) aligned, 2 59 2 first_statement fixed bin (18) unsigned unal, 2 60 2 last_statement fixed bin (18) unsigned unal, 2 61 2 insert_statement fixed bin (18) unsigned unal, 2 62 2 insert_operator fixed bin (18) unsigned unal, 2 63 2 info structure unal, 2 64 3 processed bit(1), 2 65 3 loop_entry bit(1), 2 66 3 falls_through bit(1), 2 67 3 has_label bit(1), 2 68 3 entry_pt bit(1), 2 69 3 in_queue bit(1), 2 70 3 is_back_target bit(1), 2 71 3 has_side_effects bit(1), 2 72 3 removed bit(1), 2 73 3 refreshed bit(1), 2 74 3 pad bit(26), 2 75 2 used ptr unal, 2 76 2 set ptr unal, 2 77 2 busy_on_entry ptr unal, 2 78 2 set_multiple ptr unal, 2 79 2 busy_on_exit ptr unal, 2 80 2 dominated_by ptr unal, 2 81 2 is_active_operator ptr unal, 2 82 2 always_completely_set ptr unal; 2 83 2 84 2 85 /* INPUT_TO (3 words) */ 2 86 2 87 dcl 1 input_to based aligned, 2 88 2 next pointer unaligned, 2 89 2 operator pointer unaligned, 2 90 2 which fixed bin aligned; 2 91 2 92 /* LCHAIN (2 words) */ 2 93 2 94 dcl 1 lchain based aligned, 2 95 2 next pointer unaligned, 2 96 2 value fixed bin(18) aligned; 2 97 2 98 /* LOOP (33 words) */ 2 99 2 100 dcl 1 loop based aligned, 2 101 2 number fixed bin(18), 2 102 2 depth fixed bin(18), 2 103 2 father pointer unaligned, 2 104 2 brother pointer unaligned, 2 105 2 prev_brother pointer unaligned, 2 106 2 son pointer unaligned, 2 107 2 last_son pointer unaligned, 2 108 2 entry_unit pointer unaligned, 2 109 2 members pointer unaligned, 2 110 2 back_target pointer unaligned, 2 111 2 exits pointer unaligned, 2 112 2 first_unit pointer unaligned, 2 113 2 last_unit pointer unaligned, 2 114 2 is_member pointer unaligned, 2 115 2 is_exit pointer unaligned, 2 116 2 articulation_blocks pointer unaligned, 2 117 2 used pointer unaligned, 2 118 2 set pointer unaligned, 2 119 2 busy_on_exit pointer unaligned, 2 120 2 set_multiple pointer unaligned, 2 121 2 ancestors_and_me pointer unaligned, 2 122 2 bits structure unaligned, 2 123 3 has_side_effects bit(1), 2 124 3 erases structure unaligned, 2 125 4 xr(0:7) bit(1), 2 126 4 pr(6) bit(1), 2 127 3 avoid_pr(6) bit(1), 2 128 3 all_xrs_globally_assigned bit(1), 2 129 3 pad bit(14), 2 130 2 induction_var pointer unaligned, 2 131 2 may_keep_in_xr pointer unaligned, 2 132 2 computed pointer unaligned, 2 133 2 xregs_used fixed bin(4), 2 134 2 pregs_used fixed bin(4), 2 135 2 global_xr_items pointer unaligned, 2 136 2 global_pr_items pointer unaligned, 2 137 2 range_list pointer unaligned, 2 138 2 msp pointer unaligned, 2 139 2 eligible_ind_var_op_var pointer unaligned, 2 140 2 left_shift_chain pointer unaligned; 2 141 2 142 /* OPERATOR */ 2 143 2 144 dcl 1 operator based aligned, 2 145 2 146 /* WORD 1 */ 2 147 2 148 2 op_code fixed bin(8) unal, 2 149 2 assigns_constant_to_symbol bit(1) unal, 2 150 2 freed bit(1) unal, 2 151 2 number fixed bin(7) unsigned unal, 2 152 2 coordinate fixed bin(18) unsigned unal, 2 153 2 154 /* WORD 2 */ 2 155 2 156 2 next fixed bin(18) unsigned unal, 2 157 2 back fixed bin(18) unsigned unal, 2 158 2 159 /* WORD 3 */ 2 160 2 161 2 primary pointer unal, 2 162 2 163 /* WORD 4 */ 2 164 2 165 2 output fixed bin(18) aligned, 2 166 2 167 /* WORDS 5 - n */ 2 168 2 169 2 operand(n_operands refer (operator.number)) fixed bin (18) aligned; 2 170 2 171 dcl n_operands fixed bin; 2 172 2 173 2 174 /* OPT_STATEMENT */ 2 175 2 176 dcl 1 opt_statement based aligned structure, 2 177 2 178 /* WORD 1 */ 2 179 2 180 2 op_code fixed bin(8) unal, /* must be stat_op */ 2 181 2 number fixed bin(8) unal, /* must be 0 */ 2 182 2 label fixed bin (18) unsigned unal, 2 183 2 184 /* WORD 2 */ 2 185 2 186 2 first_operator fixed bin (18) unsigned unal, 2 187 2 prev_operator fixed bin (18) unsigned unal, 2 188 2 189 /* WORD 3 */ 2 190 2 191 2 next bit(18) unal, /* "0"b = no next statement */ 2 192 2 back bit(18) unal, /* "0"b = no prev statement */ 2 193 2 194 /* WORD 4 */ 2 195 2 196 2 source_id structure unaligned, 2 197 3 file fixed bin (8) unsigned, /* 0 = first file */ 2 198 3 line bit(14), 2 199 3 statement bit(5), /* 1 = first statement */ 2 200 2 201 2 length bit(9) unaligned, 2 202 2 203 /* WORD 5 */ 2 204 2 205 2 bits structure unaligned, 2 206 3 put_in_map bit(1), 2 207 3 put_in_profile bit(1), 2 208 3 processed_by_converter bit(1), 2 209 3 referenced_backwards bit(1), 2 210 3 referenced_by_assign bit(1), 2 211 3 has_operator_list bit(1), 2 212 3 moved bit(1), 2 213 3 removable bit(1), 2 214 3 pad bit(1), 2 215 2 216 2 start fixed bin(26) unaligned, 2 217 2 218 /* WORD 6 */ 2 219 2 220 2 location bit(18) unaligned, /* (18)"1"b = no code */ 2 221 2 machine_state fixed bin (18) unsigned unaligned, 2 222 2 223 /* WORD 7 */ 2 224 2 225 2 flow_unit pointer unaligned, 2 226 2 227 /* WORD 8 */ 2 228 2 229 2 operator_list pointer unaligned; 2 230 2 231 2 232 /* PRIMARY (4 words) */ 2 233 2 234 dcl 1 primary based aligned, 2 235 2 next pointer unaligned, 2 236 2 last pointer unaligned, 2 237 2 data structure aligned, 2 238 3 expression pointer unaligned, 2 239 3 flow_unit pointer unaligned; 2 240 2 241 /* RANGE (3 words) */ 2 242 2 243 dcl 1 range based aligned, 2 244 2 next pointer unaligned, 2 245 2 variable pointer unaligned, 2 246 2 bits structure unaligned, 2 247 3 range_bits structure unaligned, 2 248 4 fb17 bit(1), 2 249 4 fb18_uns bit(1), 2 250 3 mbz bit(34); 2 251 2 252 2 253 /* END fort_opt_nodes.incl.pl1 */ 41 42 3 1 /* BEGIN fort_listing_nodes.incl.pl1 */ 3 2 3 3 /* Created: 30 August 1976, David Levin 3 4* 3 5*Last Modified: 9 October 1978, Paul Smee 3 6**/ 3 7 3 8 dcl 1 cross_reference(261120) aligned structure based(cref_base), 3 9 2 symbol fixed bin (18) unsigned unaligned, 3 10 2 line_no fixed bin(17) unaligned; 3 11 3 12 dcl 1 listing_info aligned structure based(cur_listing), 3 13 2 subprogram fixed bin (18) unsigned, 3 14 2 next fixed bin (18) unsigned, 3 15 2 first_line fixed bin (18) unsigned, 3 16 2 last_line fixed bin (18) unsigned, 3 17 2 first_cref fixed bin (18) unsigned, 3 18 2 last_cref fixed bin (18) unsigned, 3 19 2 first_error fixed bin (18) unsigned, 3 20 2 last_error fixed bin (18) unsigned; 3 21 3 22 dcl listing_seg(0:261119) fixed bin based(listing_base); 3 23 3 24 dcl 1 error_text aligned structure based, 3 25 2 next fixed bin (18) unsigned, 3 26 2 length fixed bin, 3 27 2 string char(error_text_length refer(error_text.length)) aligned; 3 28 3 29 dcl error_text_length fixed bin; 3 30 3 31 dcl 1 source_list (130560) aligned structure based (source_line_base), 3 32 2 file_number fixed bin (8) unaligned, 3 33 2 line_start fixed bin (21) unsigned unaligned, 3 34 2 unused_bits bit (6) unaligned, 3 35 2 line_length fixed bin (18) unsigned unaligned, 3 36 2 line_number_in_file fixed bin (18) unsigned unaligned; 3 37 3 38 /* END fort_listing_nodes.incl.pl1 */ 43 44 4 1 /* BEGIN fort_system_constants.incl.pl1 */ 4 2 4 3 4 4 4 5 /****^ HISTORY COMMENTS: 4 6* 1) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), 4 7* install(86-07-28,MR12.0-1105): 4 8* Fix fortran bug 428. 4 9* END HISTORY COMMENTS */ 4 10 4 11 4 12 /* Created: June 1976, David Levin */ 4 13 4 14 /* Modified: 4 15* 15 Dec 85, RW - 428: Changed max_char_length from 256 to 512. 4 16* 22 Jun 84, MM - Install typeless functions support. 4 17* 17 Jun 83, HH - 383: Added 'process_param_list_op'. 4 18* 12 Jan 83, HH - Added 'form_VLA_packed_ptr_op'. 4 19* 05 Oct 82, HH - Added 'units_per_word'. 4 20* 27 Sep 82, HH - Added 'max_fixed_bin_18', 'max_fixed_bin_24' and 'sys_info$max_seg_size'. 4 21* Removed 'max_stored_value' and 'min_stored_value'. 4 22* 24 October 1981, ME Presser - added inquire_op. 4 23* 20 October 1981, C R Davis - add (read write)_internal_file_op. 4 24* 11 May 1981, Marshall Presser - added op-codes for .EQV. and .NEQV. 4 25* 28 April 1981, Marshall Presser - added default_main_entry_point_name 4 26* 11 March 1981, Marshall Presser - add min_stored_value 4 27* 8 December 1980, C R Davis - add block_if_op, else_if_op, else_op. 4 28* 15 January 1980, C R Davis - add bits_per_char. 4 29* 21 December 1979, Richard A. Barnes - add unrecoverable_errror and 4 30* max_error_level. 4 31* 3 November 1979, Richard Barnes - add pointer_node. 4 32* 17 September 1979, Richard Barnes - add load_preg_op & load_xreg_op 4 33* 13 September 1979, Paul Smee - add colon and concat token types, 4 34* change value of EOS_token, remove default_char_size. 4 35* 31 August 1979, Charlie Davis - change offset units to 4 36* be consistent with those in runtime symbols. 4 37* 13 August 1979, Richard Barnes - add cat_op & substr_op 4 38* 19 July 1979, Richard Barnes - char mode 4 39* 10 October 1978, Paul Smee - double max_stored_value and bias. 4 40* 15 June 1978, Paul Smee - add max_num_of_rands 4 41* 16 November 1977, David Levin - add machine_state_node 4 42* 12 September 1977, Richard Barnes - new ops for loop optimizer 4 43* 30 August 1977, David Levin - change bias from 65536 to 131072. 4 44* 5 July 1977, David Levin - add open_op, close_op, and iostat_op. 4 45* 28 April 1977, David Levin - add xmit_vector_op in operator list 4 46* 22 April 1977, David Levin - add max_prec_single, last_assigned_mode 4 47* 24 February 1977, Gabriel Chang for the optimizer. 4 48* 23 February 1977, David Levin to change name of count operand. 4 49* 28 October 1976, David Levin and Gabriel Chang to add 2 new ops and 4 50* 1 new node type. 4 51* 2 September 1976, David Levin - add 8 new ops and change name of 4 52* data_op. 4 53**/ 4 54 /* SYSTEM CONSTANTS */ 4 55 4 56 dcl bias init(262144) fixed bin(19) int static options(constant); 4 57 dcl gap_value init(0) fixed bin int static options(constant); 4 58 dcl max_fixed_bin_18 init(111111111111111111b) fixed bin (18) static options (constant); 4 59 dcl max_fixed_bin_24 init(111111111111111111111111b) fixed bin (24) static options (constant); 4 60 dcl max_num_of_rands init(127) fixed bin int static options(constant); 4 61 dcl sys_info$max_seg_size 4 62 fixed bin (18) ext; 4 63 4 64 dcl ( unrecoverable_error init(3), 4 65 max_error_level init(4)) 4 66 fixed bin int static options(constant); 4 67 4 68 dcl (main_program init(0), 4 69 block_data init(1), 4 70 subroutine init(2), 4 71 function init(3), 4 72 chars_per_word init(4), 4 73 chars_per_dw init(8), 4 74 bits_per_char init(9), 4 75 first_auto_loc init(64), 4 76 max_prec_single init(8)) fixed bin(9) int static options(constant); 4 77 dcl max_char_length init(512) fixed bin(10) int static options(constant); 4 78 4 79 dcl blank_common_name init("blnk*com") char(8) aligned int static options(constant); 4 80 declare default_main_entry_point_name 4 81 char (5) int static options (constant) initial ("main_"); 4 82 declare unnamed_block_data_subprg_name 4 83 char (29) int static options (constant) initial ("unnamed block data subprogram"); 4 84 4 85 /* NODE TYPES */ 4 86 4 87 dcl (fill_node init(0), 4 88 source_node init(1), 4 89 symbol_node init(2), 4 90 dimension_node init(3), 4 91 temporary_node init(4), 4 92 constant_node init(5), 4 93 label_node init(6), 4 94 header_node init(7), 4 95 char_constant_node init(8), 4 96 array_ref_node init(9), 4 97 proc_frame_node init(10), 4 98 library_node init(11), 4 99 subprogram_node init(12), 4 100 arg_desc_node init(13), 4 101 pointer_node init(14), 4 102 machine_state_node init(15)) fixed bin(4) aligned internal static options(constant); 4 103 4 104 /* DATA TYPES */ 4 105 4 106 dcl (int_mode init(1), 4 107 real_mode init(2), 4 108 dp_mode init(3), 4 109 cmpx_mode init(4), 4 110 logical_mode init(5), 4 111 char_mode init(6), 4 112 typeless_mode init(7), 4 113 last_assigned_mode init(7)) fixed bin(4) aligned internal static options(constant); 4 114 4 115 dcl data_type_size(7) init(1,1,2,2,1,0,1) fixed bin int static options(constant); 4 116 4 117 4 118 /* OPERAND TYPES */ 4 119 4 120 dcl (variable_type init(1), 4 121 constant_type init(2), 4 122 array_ref_type init(3), 4 123 temp_type init(4), 4 124 count_type init(5), 4 125 rel_constant init(6), 4 126 bif init(7), 4 127 statement_function init(8), 4 128 external init(9), 4 129 entry_type init(10), 4 130 dummy init(11), 4 131 error init(12)) fixed bin(4) aligned internal static options(constant); 4 132 4 133 4 134 /* OFFSET UNITS */ 4 135 4 136 dcl 4 137 (word_units init (0), 4 138 bit_units init (1), 4 139 char_units init (2), 4 140 halfword_units init (3)) fixed bin (3) aligned internal static options(constant); 4 141 4 142 dcl units_per_word (0:3) init (1, 36, 4, 2) fixed bin (6) static options (constant); 4 143 4 144 4 145 /* TOKEN MASKS */ 4 146 4 147 dcl 4 148 (is_operand initial("101000000"b), 4 149 is_operator initial("010000000"b), 4 150 is_constant initial("001000000"b), 4 151 is_arith_constant initial("000100000"b)) bit(9) aligned internal static options(constant); 4 152 4 153 4 154 /* TOKEN TYPES */ 4 155 4 156 dcl (no_token initial("000000000"b), 4 157 ident initial("100000000"b), 4 158 plus initial("010000001"b), 4 159 minus initial("010000010"b), 4 160 asterisk initial("010000011"b), 4 161 slash initial("010000100"b), 4 162 expon initial("010000101"b), 4 163 not initial("010000110"b), 4 164 and initial("010000111"b), 4 165 or initial("010001000"b), 4 166 eq initial("010001001"b), 4 167 ne initial("010001010"b), 4 168 lt initial("010001011"b), 4 169 gt initial("010001100"b), 4 170 le initial("010001101"b), 4 171 ge initial("010001110"b), 4 172 assign initial("010001111"b), 4 173 comma initial("010010000"b), 4 174 left_parn initial("010010001"b), 4 175 right_parn initial("010010010"b), 4 176 apostrophe initial("010010011"b), 4 177 colon initial("010010100"b), 4 178 concat initial("010010101"b), 4 179 substr_left_parn initial("010010110"b), 4 180 eqv initial("010010111"b), 4 181 neqv initial("010011000"b), 4 182 EOS_token initial("010011111"b), 4 183 char_string initial("001000001"b), 4 184 logical_const initial("001000010"b), 4 185 false initial("001000010"b), /* Must be identical to true except low order bit off. */ 4 186 true initial("001000011"b), /* Must be identical to false except low order bit on. */ 4 187 label_const initial("001000100"b), 4 188 octal_const initial("001000101"b), 4 189 dec_int initial("001100110"b), 4 190 real_const initial("001100111"b), 4 191 double_const initial("001101000"b), 4 192 complex_const initial("001101001"b)) bit(9) aligned internal static options(constant); 4 193 4 194 4 195 /* OPERATOR NAMES */ 4 196 4 197 declare 4 198 (assign_op initial(1), 4 199 add_op initial(2), 4 200 sub_op initial(3), 4 201 mult_op initial(4), 4 202 div_op initial(5), 4 203 exponentiation_op initial(6), 4 204 negate_op initial(7), 4 205 less_op initial(8), 4 206 less_or_equal_op initial(9), 4 207 equal_op initial(10), 4 208 not_equal_op initial(11), 4 209 greater_or_equal_op initial(12), 4 210 greater_op initial(13), 4 211 or_op initial(14), 4 212 and_op initial(15), 4 213 not_op initial(16), 4 214 jump_op initial(17), 4 215 jump_logical_op initial(18), 4 216 jump_arithmetic_op initial(19), 4 217 jump_computed_op initial(20), 4 218 jump_assigned_op initial(21), 4 219 assign_label_op initial(22), 4 220 read_op initial(23), 4 221 write_op initial(24), 4 222 format_op initial(25), 4 223 end_label_op initial(26), 4 224 error_label_op initial(27), 4 225 xmit_scalar_op initial(28), 4 226 xmit_array_op initial(29), 4 227 xmit_vector_op initial(30), 4 228 endfile_op initial(31), 4 229 rewind_op initial(32), 4 230 backspace_op initial(33), 4 231 margin_op initial(34), 4 232 openfile_op initial(35), 4 233 closefile_op initial(36), 4 234 record_number_op initial(37), 4 235 string_op initial(38), 4 236 string_length_op initial(39), 4 237 terminate_op initial(40), 4 238 return_op initial(41), 4 239 pause_op initial(42), 4 240 stop_op initial(43), 4 241 item_op initial(44), 4 242 exit_op initial(45), 4 243 eol_op initial(46), 4 244 do_op initial(47), 4 245 builtin_op initial(48), 4 246 sf_op initial(49), 4 247 sf_def_op initial(50), 4 248 subscript_op initial(51), 4 249 func_ref_op initial(52), 4 250 block_data_op initial(53), 4 251 increment_polish_op initial(54), 4 252 main_op initial(55), 4 253 func_op initial(56), 4 254 subr_op initial(57), 4 255 stat_op initial(58), 4 256 label_op initial(59), 4 257 call_op initial(60), 4 258 chain_op initial(61), 4 259 endunit_op initial(62), 4 260 non_executable initial(63), 4 261 no_op initial(64), 4 262 form_VLA_packed_ptr_op initial(65), 4 263 opt_subscript_op initial(66), 4 264 left_shift_op initial(67), 4 265 right_shift_op initial(68), 4 266 store_zero_op initial(69), 4 267 storage_add_op initial(70), 4 268 storage_sub_op initial(71), 4 269 neg_storage_add_op initial(72), 4 270 storage_add_one_op initial(73), 4 271 namelist_op initial(74), 4 272 open_op initial(75), 4 273 close_op initial(76), 4 274 iostat_op initial(77), 4 275 convert_to_int_op initial(78), 4 276 convert_to_real_op initial(79), 4 277 convert_to_dp_op initial(80), 4 278 convert_to_cmpx_op initial(81), 4 279 read_scalar_op initial(82), 4 280 read_array_op initial(83), 4 281 read_vector_op initial(84), 4 282 write_scalar_op initial(85), 4 283 write_array_op initial(86), 4 284 write_vector_op initial(87), 4 285 jump_true_op initial(88), 4 286 jump_false_op initial(89), 4 287 sub_index_op initial(90), 4 288 loop_end_op initial(91), 4 289 read_namelist_op initial(92), 4 290 write_namelist_op initial(93), 4 291 decode_string_op initial(94), 4 292 encode_string_op initial(95), 4 293 cat_op initial(96), 4 294 substr_op initial(97), 4 295 load_xreg_op initial(98), 4 296 load_preg_op initial(99), 4 297 block_if_op initial(100), 4 298 else_if_op initial(101), 4 299 else_op initial(102), 4 300 equiv_op initial (103), 4 301 not_equiv_op initial (104), 4 302 read_internal_file_op initial (105), 4 303 write_internal_file_op initial (106), 4 304 inquire_op initial (107), 4 305 process_param_list_op initial (108), 4 306 lhs_fld_op initial (109), 4 307 last_assigned_op initial (109)) fixed bin(18) internal static options(constant); 4 308 4 309 /* END fort_system_constants.incl.pl1 */ 45 46 47 dcl 1 shared_globals structure aligned based (shared_struc_ptr), 5 1 5 2 /* BEGIN fort_shared_vars.incl.pl1 */ 5 3 5 4 5 5 5 6 /****^ HISTORY COMMENTS: 5 7* 1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter), 5 8* install(86-07-28,MR12.0-1105): 5 9* Fix fortran bug 463. 5 10* END HISTORY COMMENTS */ 5 11 5 12 5 13 /* Created: June 1976, David Levin 5 14* 5 15* Modified: 30 Aug 76, David Levin - to add global variables for listing segment. 5 16* Modified: 22 Nov 76, Richard Barnes - to add profile_size 5 17* Modified: 24 Feb 77, Gabriel Chang - for the optimizer 5 18* Modified: 06 Oct 77, Richard Barnes - for the loop optimizer 5 19* Modified: 16 Nov 77, David Levin - add next_free_(temp array_ref). 5 20* Modified: 09 Oct 78, Paul Smee - for larger common and arrays. 5 21* Modified: 03 Apr 79, Paul Smee - add list of include file data. 5 22* Modified: 17 May 79, Paul Smee - add cur_statement_list. 5 23* Modified: 28 Jun 79, Paul Smee - add compile-time math entry arrays. 5 24* Modified: 13 Sep 79, Paul Smee - add default_char_size. 5 25* Modified: 18 Dec 79, Richard Barnes - add free and freei 5 26* Modified: 03 Mar 80, C R Davis - add must_save_stack_extent. 5 27* Modified: 15 Mar 82, T G Oke - add source (line_number, file_number). 5 28* Modified: 20 Sept 82, T G Oke - add VLA_is_256K flag 5 29* Modified: 22 Sept 82, T G Oke - add area creation info to pass to 5 30* listing generator. 5 31* Modified: 17 May 83, M Mabey - add declared_options. 5 32* Modified: 02 Aug 85, B Wong - 463: changed 'must_save_stack_extent' 5 33* to 'pad' since the variable is no longer used. 5 34**/ 5 35 5 36 2 polish_base ptr, 5 37 2 operand_base ptr, 5 38 2 object_base ptr, 5 39 2 quadruple_base ptr, 5 40 2 opt_base ptr, 5 41 2 relocation_base ptr, 5 42 5 43 2 cref_base ptr, /* base of cross reference segment */ 5 44 2 source_line_base ptr, /* base of source line offset segment */ 5 45 2 listing_base ptr, /* base of listing info segment */ 5 46 2 cur_listing ptr, /* points to listing info for the active subprogram */ 5 47 5 48 2 free(2:4) ptr, /* free chains for optimizer */ 5 49 2 freei ptr, /* .. */ 5 50 5 51 2 polish_max_len fixed bin (19), 5 52 2 operand_max_len fixed bin (19), 5 53 2 object_max_len fixed bin (19), 5 54 2 quad_max_len fixed bin (19), 5 55 2 opt_max_len fixed bin (19), 5 56 5 57 2 next_free_polish fixed bin (18), 5 58 2 next_free_operand fixed bin (18), 5 59 2 next_free_object fixed bin (18), 5 60 2 next_free_listing fixed bin (18), 5 61 2 next_free_quad fixed bin (18), 5 62 2 next_free_array_ref fixed bin (18), /* Chain for freed array_ref nodes. */ 5 63 2 next_free_temp fixed bin (18), /* Chain for freed temporary nodes. */ 5 64 2 next_free_opt fixed bin (18), 5 65 5 66 2 first_segment fixed bin, 5 67 2 number_of_source_segments fixed bin (8), 5 68 2 number_of_lines fixed bin, 5 69 2 number_of_crefs fixed bin, 5 70 2 profile_size fixed bin, 5 71 5 72 2 main_entry_point_name char (32) varying, 5 73 5 74 2 cur_statement fixed bin (18), 5 75 2 cur_statement_list fixed bin (17), 5 76 2 cur_subprogram fixed bin (18), 5 77 2 first_subprogram fixed bin (18), 5 78 2 last_subprogram fixed bin (18), 5 79 2 unnamed_block_data_subprogram 5 80 fixed bin (18), 5 81 2 first_entry_name fixed bin (18), 5 82 2 last_entry_name fixed bin (18), 5 83 5 84 2 constant_info (4) aligned structure, 5 85 3 constant_count fixed bin (17), 5 86 3 first_constant fixed bin (18), 5 87 3 last_constant fixed bin (18), 5 88 5 89 2 options aligned, 5 90 3 user_options aligned like fortran_options, 5 91 3 system_options aligned, 5 92 4 is_fast bit (1) unaligned, 5 93 4 namelist_used bit (1) unaligned, 5 94 4 compile_only bit (1) unaligned, 5 95 4 VLA_is_256K bit (1) unaligned, /* FLAG 255/256K code */ 5 96 4 pad bit (32) unaligned, 5 97 5 98 2 incl_data aligned, 5 99 3 incl_count fixed bin, 5 100 3 file_list (0:255), 5 101 4 source_node_offset fixed bin (18), 5 102 4 incl_len fixed bin (21), 5 103 4 incl_ptr unaligned ptr, 5 104 5 105 2 create_constant entry (fixed bin (4), bit (72) aligned) returns (fixed bin (18)) 5 106 variable, 5 107 2 create_char_constant entry (char (*)) returns (fixed bin (18)) 5 108 variable, 5 109 2 print_message entry options (variable) 5 110 variable, 5 111 2 get_next_temp_segment entry (ptr, fixed bin (18)) returns (ptr) 5 112 variable, 5 113 2 negate_round (6) entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) 5 114 returns (bit (72)) variable, 5 115 2 negate_trunc (6) entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) 5 116 returns (bit (72)) variable, 5 117 2 binop_round (6,6) entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) 5 118 returns (bit (72)) variable, 5 119 2 binop_trunc (6,6) entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) 5 120 returns (bit (72)) variable, 5 121 2 comp_parm (6,6) entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) 5 122 returns (bit (72)) variable, 5 123 2 conv_round (6,6) entry (bit (72), fixed bin (35)) 5 124 returns (bit (72)) variable, 5 125 2 conv_trunc (6,6) entry (bit (72), fixed bin (35)) 5 126 returns (bit (72)) variable, 5 127 2 pad bit (1) aligned, 5 128 5 129 /* The following are used by "print_message - decode_source_id" if use_source_info set. */ 5 130 5 131 2 use_source_info bit (1) aligned, 5 132 2 source_file_number fixed bin (35), 5 133 2 source_line_number fixed bin (35), 5 134 2 Area_create_first fixed bin (18), /* start of text to do creation */ 5 135 2 Area_create_last fixed bin (18), /* Last item */ 5 136 2 Area_init_first fixed bin (18), /* start of text to init areas */ 5 137 2 Area_init_last fixed bin (18), /* Last item */ 5 138 2 declared_options aligned like fortran_declared; 5 139 5 140 dcl num_of_word_constants fixed bin (17) defined (constant_info (1).constant_count); 5 141 dcl first_word_constant fixed bin (18) defined (constant_info (1).first_constant); 5 142 dcl last_word_constant fixed bin (18) defined (constant_info (1).last_constant); 5 143 5 144 dcl num_of_dw_constants fixed bin (17) defined (constant_info (2).constant_count); 5 145 dcl first_dw_constant fixed bin (18) defined (constant_info (2).first_constant); 5 146 dcl last_dw_constant fixed bin (18) defined (constant_info (2).last_constant); 5 147 5 148 dcl num_of_char_constants fixed bin (17) defined (constant_info (3).constant_count); 5 149 dcl first_char_constant fixed bin (18) defined (constant_info (3).first_constant); 5 150 dcl last_char_constant fixed bin (18) defined (constant_info (3).last_constant); 5 151 5 152 dcl num_of_block_constants fixed bin (17) defined (constant_info (4).constant_count); 5 153 dcl first_block_constant fixed bin (18) defined (constant_info (4).first_constant); 5 154 dcl last_block_constant fixed bin (18) defined (constant_info (4).last_constant); 5 155 5 156 /* END fort_shared_vars.incl.pl1 */ 48 49 6 1 /* BEGIN INCLUDE FILE fort_options.incl.pl1 */ 6 2 6 3 /****^ *********************************************************** 6 4* * * 6 5* * Copyright, (C) Honeywell Information Systems Inc., 1987 * 6 6* * * 6 7* *********************************************************** */ 6 8 6 9 /****^ HISTORY COMMENTS: 6 10* 1) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), 6 11* install(86-07-28,MR12.0-1105): 6 12* Fix fortran bug 473. 6 13* 2) change(87-06-23,RWaters), approve(87-06-23,MCR7703), audit(87-07-10,Huen), 6 14* install(87-08-06,MR12.1-1069): 6 15* Implemented SCP 6315: fortran error-handling argument. 6 16* END HISTORY COMMENTS */ 6 17 6 18 6 19 /* 6 20* Modified: 12 May 87 by RWaters added debug_io 6 21* Modified: 19 February 1986 by B. Wong & A. Ginter - 473.a: Correct 6 22* comments and size of pad field in fort_declared 6 23* and pad out dfast and fast bit masks to two words. 6 24* Modified: 09 October 1985 by B. Wong - 473: add VLA_auto, VLA_static, 6 25* VLA_parm, VLC, LA_auto, and LA_static. Remove VLA and LA. 6 26* Modified: 28 March 1984 by M. Mabey - Install HFP support. 6 27* Modified: 21 September 1983 by M. Mabey - correct size of pad field in fortran_declared. 6 28* Modified: 16 May 1983 by M. Mabey - add fortran_declared 6 29* Modified: 18 December 1982 by T. Oke - Add 'long_profile'. 6 30* Modified: 22 September 1982 by T. Oke - add VLA and LA 6 31* Modified: 3 May 1982 by T. Oke - add check_multiply 6 32* Modified: 06/24/81 by S. Herbst - add do_rounding & auto_zero to fast_mask and dfast_mask 6 33* Modified: 26 February 1980 by C R Davis - add fast_mask, fix dfast_mask. 6 34* Modified: 31 January 1980 by C R Davis - add stringrange. 6 35* Modified: 13 September 1979 by Paul E. Smee--add ansi_77. 6 36* Modified: 05 December 1978 by Paul E. Smee--add do_rounding, auto_zero. 6 37* Modified: 25 January 1978 by Richard A. Barnes for the loop optimizer 6 38**/ 6 39 6 40 declare 6 41 6 42 1 fortran_options aligned based, 6 43 2 use_library bit (1) unaligned, /* (1) ON if library statements will be parsed */ 6 44 2 optimize bit (1) unaligned, /* (2) ON if optimized code is to be produced */ 6 45 2 time bit (1) unaligned, /* (3) ON for compile timing */ 6 46 2 source_format unaligned, 6 47 3 has_line_numbers bit (1) unaligned, /* (4) ON if each line begins with a line number */ 6 48 3 fold bit (1) unaligned, /* (5) ON if variable names are to be folded to lowercase */ 6 49 3 card bit (1) unaligned, /* (6) ON for card format */ 6 50 3 convert bit (1) unaligned, /* (7) ON for card format to be converted */ 6 51 2 listing unaligned, 6 52 3 source bit (1) unaligned, /* (8) ON for listing of numbered source */ 6 53 3 symbol bit (1) unaligned, /* (9) ON for listing with symbol map */ 6 54 3 map bit (1) unaligned, /* (10) ON for listing with statement map */ 6 55 3 list bit (1) unaligned, /* (11) ON for listing with assembler instructions */ 6 56 2 error_messages unaligned, 6 57 3 brief bit (1) unaligned, /* (12) ON for brief error messages */ 6 58 3 severity fixed bin (3), /* (13-16) suppresses messages below this severity */ 6 59 2 debugging unaligned, 6 60 3 subscriptrange bit (1) unaligned, /* (17) ON for subscript range checking */ 6 61 3 stringrange bit (1) unaligned, /* (18) ON for string range checking */ 6 62 3 brief_table bit (1) unaligned, /* (19) ON for statement table */ 6 63 3 table bit (1) unaligned, /* (20) ON for statement and symbol table */ 6 64 3 profile bit (1) unaligned, /* (21) ON to generate code to meter statements */ 6 65 3 check bit (1) unaligned, /* (22) ON for syntactic and semantic checking only */ 6 66 2 system_debugging unaligned, 6 67 3 stop_after_cg bit (1) unaligned, /* (23) ON if debug stop after code generator */ 6 68 3 stop_after_parse bit (1) unaligned, /* (24) ON if debug stop after parse */ 6 69 2 relocatable bit (1) unaligned, /* (25) ON if relocatable object segment generated */ 6 70 2 optimizing unaligned, 6 71 3 time_optimizer bit (1) unaligned, /* (26) ON if timings for optimizer requested */ 6 72 /* (27) ON if optimizer can loosen safety constraints */ 6 73 3 ignore_articulation_blocks bit (1) unaligned, 6 74 3 consolidate bit(1) unaligned, /* (28) ON if optimizer should run consolidation phase */ 6 75 2 do_rounding bit(1) unaligned, /* (29) ON if floating point round should be used */ 6 76 2 auto_zero bit(1) unaligned, /* (30) ON if auto storage should be zeroed when allocated */ 6 77 2 ansi_77 bit (1) unaligned, /* (31) ON if ansi77 rules are to be followed */ 6 78 2 check_multiply bit (1) unaligned, /* (32) ON if check integer multiply extent */ 6 79 2 VLA_auto bit (1) unaligned, /* (33) ON if auto VLA's being done */ 6 80 2 VLA_parm bit (1) unaligned, /* (34) ON if parm VLA's being done */ 6 81 2 VLA_static bit (1) unaligned, /* (35) ON if static VLA's being done */ 6 82 2 VLC bit (1) unaligned, /* (36) ON if VLC's being done */ 6 83 2 LA_auto bit (1) unaligned, /* (1) ON if auto LA's being done */ 6 84 2 LA_static bit (1) unaligned, /* (2) ON if static LA's being done */ 6 85 2 long_profile bit (1) unaligned, /* (3) ON to generate long_profile */ 6 86 2 static_storage bit (1) unaligned, /* (4) ON if static storage */ 6 87 2 hfp bit (1) unaligned, /* (5) ON if using hex floating point math */ 6 88 2 debug_io bit (1) unaligned, /* (6) */ 6 89 2 pad bit(30) unaligned; /* (7-36) Pad bits */ 6 90 6 91 declare 6 92 6 93 1 fortran_declared aligned based, 6 94 2 ansi66 bit(1) unaligned, /* (1) First word */ 6 95 2 ansi77 bit(1) unaligned, /* (2) */ 6 96 2 auto bit(1) unaligned, /* (3) */ 6 97 2 auto_zero bit(1) unaligned, /* (4) */ 6 98 2 brief bit(1) unaligned, /* (5) */ 6 99 2 binary_floating_point bit(1) unaligned, /* (6) */ 6 100 2 brief_table bit(1) unaligned, /* (7) */ 6 101 2 card bit(1) unaligned, /* (8) */ 6 102 2 check bit(1) unaligned, /* (9) */ 6 103 2 check_multiply bit(1) unaligned, /* (10) */ 6 104 2 consolidate bit(1) unaligned, /* (11) */ 6 105 2 debug bit(1) unaligned, /* (12) */ 6 106 2 debug_cg bit(1) unaligned, /* (13) */ 6 107 2 debug_io bit(1) unaligned, /* (14) */ 6 108 2 default_full bit(1) unaligned, /* (15) */ 6 109 2 default_safe bit(1) unaligned, /* (16) */ 6 110 2 fold bit(1) unaligned, /* (17) */ 6 111 2 free bit(1) unaligned, /* (18) */ 6 112 2 full_optimize bit(1) unaligned, /* (19) */ 6 113 2 hexadecimal_floating_point bit(1) unaligned, 6 114 /* (20) */ 6 115 2 la_auto bit(1) unaligned, /* (21) */ 6 116 2 la_static bit(1) unaligned, /* (22) */ 6 117 2 large_array bit(1) unaligned, /* (23) */ 6 118 2 line_numbers bit(1) unaligned, /* (24) */ 6 119 2 list bit(1) unaligned, /* (25) */ 6 120 2 long bit(1) unaligned, /* (26) */ 6 121 2 long_profile bit(1) unaligned, /* (27) */ 6 122 2 map bit(1) unaligned, /* (28) */ 6 123 2 no_auto_zero bit(1) unaligned, /* (29) */ 6 124 2 no_check bit(1) unaligned, /* (30) */ 6 125 2 no_fold bit(1) unaligned, /* (31) */ 6 126 2 no_large_array bit(1) unaligned, /* (32) */ 6 127 2 no_line_numbers bit(1) unaligned, /* (33) */ 6 128 2 no_map bit(1) unaligned, /* (34) */ 6 129 2 no_optimize bit(1) unaligned, /* (35) */ 6 130 2 no_check_multiply bit(1) unaligned, /* (36) */ 6 131 2 no_debug_io bit(1) unal, /* (1) Second Word */ 6 132 2 no_stringrange bit(1) unaligned, /* (2) */ 6 133 2 no_subscriptrange bit(1) unaligned, /* (3) */ 6 134 2 no_table bit(1) unaligned, /* (4) */ 6 135 2 no_very_large_array bit(1) unaligned, /* (5) */ 6 136 2 no_vla_parm bit(1) unaligned, /* (6) */ 6 137 2 no_version bit(1) unaligned, /* (7) */ 6 138 2 non_relocatable bit(1) unaligned, /* (8) */ 6 139 2 optimize bit(1) unaligned, /* (9) */ 6 140 2 profile bit(1) unaligned, /* (10) */ 6 141 2 relocatable bit(1) unaligned, /* (11) */ 6 142 2 round bit(1) unaligned, /* (12) */ 6 143 2 safe_optimize bit(1) unaligned, /* (13) */ 6 144 2 severity fixed bin(3) unaligned, /* (14-16) */ 6 145 2 static bit(1) unaligned, /* (17) */ 6 146 2 stringrange bit(1) unaligned, /* (18) */ 6 147 2 subscriptrange bit(1) unaligned, /* (19) */ 6 148 2 table bit(1) unaligned, /* (20) */ 6 149 2 time bit(1) unaligned, /* (21) */ 6 150 2 time_ot bit(1) unaligned, /* (22) */ 6 151 2 top_down bit(1) unaligned, /* (23) */ 6 152 2 truncate bit(1) unaligned, /* (24) */ 6 153 2 version bit(1) unaligned, /* (25) */ 6 154 2 very_large_array bit(1) unaligned, /* (26) */ 6 155 2 very_large_common bit(1) unaligned, /* (27) */ 6 156 2 vla_auto bit(1) unaligned, /* (28) */ 6 157 2 vla_parm bit(1) unaligned, /* (29) */ 6 158 2 vla_static bit(1) unaligned, /* (30) */ 6 159 2 pad bit(6) unaligned; /* (31-36) */ 6 160 6 161 6 162 declare /* Options used by DFAST */ 6 163 6 164 dfast_mask bit (72) internal static options (constant) initial ("100110000000000010100000000011"b); 6 165 /* use_library, has_line_numbers, fold, subscriptrange, brief_table */ 6 166 6 167 6 168 declare /* Options used by FAST */ 6 169 6 170 fast_mask bit (72) internal static options (constant) initial ("000100000000000010100000000011"b); 6 171 /* has_line_numbers, subscriptrange, brief_table */ 6 172 6 173 /* END INCLUDE FILE fort_options.incl.pl1 */ 50 51 52 dcl 1 cg_globals structure aligned based (cg_struc_ptr), 7 1 7 2 /* BEGIN fort_cg_vars.incl.pl1 */ 7 3 7 4 /* Created: June 1976 7 5* 7 6* Modified: 7 7* 9 December 1976, David Levin - change version_name to ext static 7 8* 10 September 1976, David Levin - to add date time compiled, user id, options,version, and compiler name 7 9* 6 June 1978, Richard Barnes - for loop optimizer 7 10* 9 Oct 1978, Paul E. Smee - changes for larger common and arrays. 7 11* 30 Nov 1978, Paul E. Smee - add fort_version_info$version_number*/ 7 12 7 13 2 num_of_lib_names fixed bin(17), 7 14 2 first_lib_name fixed bin (18) unsigned, 7 15 2 last_lib_name fixed bin (18) unsigned, 7 16 7 17 2 error_level fixed bin(17), 7 18 7 19 2 message_structure structure aligned, 7 20 3 message_number fixed bin (18), 7 21 3 number_of_operands fixed bin, 7 22 3 operands(3), 7 23 4 is_string bit(1) aligned, 7 24 4 operand_index fixed bin (18), 7 25 4 string_length fixed bin, 7 26 4 string_ptr ptr, 7 27 7 28 2 print_message_op entry variable, 7 29 2 create_constant_block entry(ptr,fixed bin) returns(fixed bin (18) unsigned) 7 30 variable, 7 31 2 date_time_compiled fixed bin(71), 7 32 2 objectname char(32) varying, 7 33 2 vuser_id char(32) varying, 7 34 2 options_string char(256) varying; 7 35 7 36 dcl fort_version_info$version_name char(132) varying ext static; 7 37 dcl fort_version_info$version_number char(16) ext static; 7 38 7 39 dcl compiler_name char(8) int static options(constant) init("fortran2"); 7 40 7 41 /* END fort_cg_vars.incl.pl1 */ 53 54 8 1 /* BEGIN INCLUDE FILE definition.incl.pl1 */ 8 2 8 3 8 4 8 5 /****^ HISTORY COMMENTS: 8 6* 1) change(86-05-02,Elhard), approve(86-05-02,MCR7391), 8 7* audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222): 8 8* Modified to add indirect bit to definition flags. 8 9* END HISTORY COMMENTS */ 8 10 8 11 8 12 dcl 1 definition aligned based, 8 13 2 forward unal bit(18), /* offset of next def */ 8 14 2 backward unal bit(18), /* offset of previous def */ 8 15 2 value unal bit(18), 8 16 2 flags unal, 8 17 3 new bit(1), 8 18 3 ignore bit(1), 8 19 3 entry bit(1), 8 20 3 retain bit(1), 8 21 3 argcount bit(1), 8 22 3 descriptors bit(1), 8 23 3 indirect bit(1), 8 24 3 unused bit(8), 8 25 2 class unal bit(3), 8 26 2 symbol unal bit(18), /* offset of ACC for symbol */ 8 27 2 segname unal bit(18); /* offset of segname def */ 8 28 8 29 /* END INCLUDE FILE definition.incl.pl1 */ 55 9 1 /* BEGIN INCLUDE FILE segname_def.incl.pl1 */ 9 2 9 3 dcl 1 segname_def aligned based, 9 4 2 forward unal bit(18), /* offset of next def */ 9 5 2 backward unal bit(18), /* offset of previous def */ 9 6 2 next unal bit(18), /* offset of next segname def */ 9 7 2 flags unal, 9 8 3 new bit(1), 9 9 3 ignore bit(1), 9 10 3 entry bit(1), 9 11 3 retain bit(1), 9 12 3 descriptors bit(1), 9 13 3 unused bit(10), 9 14 2 class unal bit(3), 9 15 2 symbol unal bit(18), /* offset of ACC for symbol */ 9 16 2 defblock unal bit(18); /* offset of head of this defblock */ 9 17 9 18 /* END INCLUDE FILE segname_def.incl.pl1 */ 56 57 58 dcl 1 symtab_parameters structure aligned, 10 1 /* BEGIN INCLUDE FILE fort_symtab_parms.incl.pl1 10 2* 10 3* Read only parameters passed to fort_symbol_table which describe the 10 4* partially built object segment. 10 5* 10 6*Written: 23 August 1979 by C R Davis 10 7**/ 10 8 10 9 2 link_base_ptr pointer, 10 10 2 link_reloc_base_ptr pointer, 10 11 2 def_reloc_base_ptr pointer, 10 12 2 current_text_offset fixed binary (18), 10 13 2 current_def_offset fixed binary (18), 10 14 2 current_link_offset fixed binary (18), 10 15 2 final_text_offset fixed binary (18), 10 16 2 profile_offset fixed binary (18), 10 17 2 star_symbol_link fixed binary (18), 10 18 2 first_namelist_symbol fixed binary (18); 10 19 10 20 /* END INCLUDE FILE fort_symtab_parms.incl.pl1 */ 59 11 1 /* BEGIN INCLUDE FILE ... long_profile.incl.pl1 */ 11 2 /* coded December 1, 1976 by Richard A. Barnes */ 11 3 11 4 dcl 1 long_profile_header based aligned, 11 5 2 last_vcpu fixed bin(71), /* last virtual cpu reading */ 11 6 2 last_pf fixed bin, /* last page faults reading */ 11 7 2 last_offset fixed bin, /* offset of last profile entry metered */ 11 8 2 nentries fixed bin, /* number of profile entries */ 11 9 2 dummy like long_profile_entry aligned, /* dummy profile entry */ 11 10 2 control like long_profile_entry aligned; /* control profile entry for overhead calc */ 11 11 11 12 dcl 1 long_profile_entry based aligned, 11 13 2 map bit(18) unaligned, /* rel ptr to statement map entry */ 11 14 2 skip bit(18) unaligned, 11 15 2 count fixed bin, /* number of times stmt encountered */ 11 16 2 vcpu fixed bin, /* total execution time for this statement */ 11 17 2 pf fixed bin; /* total page faults for this statement */ 11 18 11 19 dcl (dummy_entry_offset init(5), /* offset in long_profile_header of dummy */ 11 20 control_entry_offset init(9)) /* offset in long_profile_header of control */ 11 21 fixed bin int static options(constant); 11 22 11 23 /* END INCLUDE FILE ... long_profile.incl.pl1 */ 60 61 62 dcl fort_make_symbol_section entry (ptr, ptr, ptr, fixed bin (18), fixed bin (18)); 63 64 65 shared_struc_ptr = p1; 66 cg_struc_ptr = p2; 67 object_max_len = shared_globals.object_max_len; 68 operand_max_len = shared_globals.operand_max_len; 69 polish_max_len = shared_globals.polish_max_len; 70 opt_max_len = shared_globals.opt_max_len; 71 72 73 object_base = shared_globals.object_base; 74 operand_base = shared_globals.operand_base; 75 polish_base = shared_globals.polish_base; 76 relocation_base = shared_globals.relocation_base; 77 quadruple_base = shared_globals.quadruple_base; 78 opt_base = shared_globals.opt_base; 79 80 81 call code_generator; 82 12 1 /* BEGIN fort_utilities.incl.pl1 */ 12 2 12 3 /* Created: October 1977, Richard Barnes 12 4* 12 5* Modified: 12 6* 22 May 1978, DSL - add create_constant. 12 7* 09 Oct 1978, PES - make create_(constant node) return fixed bin(18) unsigned. 12 8* 13 Dec 1978, PES - Get create_node from include file, rather than copy. 12 9**/ 12 10 13 1 /* BEGIN fort_create_node.incl.pl1 */ 13 2 13 3 /* Created: October 1977, Richard Barnes 13 4* 13 5* Modified: 13 6* 22 May 1978, DSL - add create_constant. 13 7* 09 Oct 1978, PES - make create_(constant node) return fixed bin(18) unsigned. 13 8* 13 Dec 1978, PES - changes for large common and arrays. 13 9**/ 13 10 create_node: proc(type,length) returns(fixed bin (18)); 13 11 13 12 dcl length fixed bin; 13 13 dcl offset fixed bin(18); 13 14 dcl type fixed bin(4); 13 15 dcl storage(length) fixed bin aligned based; 13 16 dcl x(0:operand_max_len-1) fixed bin(35) aligned based(operand_base); 13 17 dcl (addr,char,ltrim,unspec) builtin; 13 18 13 19 13 20 if (length + next_free_operand) < operand_max_len 13 21 then do; 13 22 offset = next_free_operand; 13 23 next_free_operand = next_free_operand + length; 13 24 unspec(addr(x(offset)) -> storage) = "0"b; 13 25 addr(x(offset)) -> node.node_type = type; 13 26 return(offset); 13 27 end; 13 28 else do; 13 29 call print_message(407, "operand region", ltrim(char(operand_max_len))); /* FATAL */ 13 30 end; 13 31 13 32 end create_node; 13 33 13 34 /* END fort_create_node.incl.pl1 */ 12 11 12 12 12 13 create_constant: proc(data_type,value) returns(fixed bin (18)); 12 14 12 15 dcl (data_type,a_data_type) fixed bin(4); /* data type of constant */ 12 16 dcl (value,a_value) bit(72) aligned; /* value of constant */ 12 17 12 18 dcl addr builtin; 12 19 dcl binary builtin; 12 20 dcl bool builtin; 12 21 dcl char builtin; 12 22 dcl data_size fixed bin(17); 12 23 dcl decimal builtin; 12 24 dcl hash_index fixed bin; 12 25 dcl hash_table(0:hash_table_size-1) fixed bin(35) aligned based(operand_base); 12 26 dcl hash_table_size fixed bin int static options(constant) init(211); 12 27 dcl hbound builtin; 12 28 dcl ltrim builtin; 12 29 dcl mod builtin; 12 30 dcl mod_2_sum bit(36) aligned; 12 31 dcl node_offset fixed bin; 12 32 dcl node_ptr pointer; 12 33 dcl size builtin; 12 34 dcl v_array(2) bit(36) aligned based(addr(a_value)); 12 35 dcl x(0:operand_max_len-1) fixed bin(35) aligned based(operand_base); 12 36 14 1 /* BEGIN INCLUDE FILE relocation_bits.incl.pl1 */ 14 2 14 3 /* This include file defines the relocation bits as bit (6) entities. See 14 4* also relbts.incl.pl1 and reloc_lower.incl.pl1. */ 14 5 14 6 dcl ( rc_a initial("000000"b), /* absolute */ 14 7 rc_t initial("010000"b), /* text */ 14 8 rc_nt initial("010001"b), /* negative text */ 14 9 rc_lp18 initial("010010"b), /* linkage, 18 bit */ 14 10 rc_nlp18 initial("010011"b), /* negative link, 18 bit */ 14 11 rc_lp15 initial("010100"b), /* linkage, 15 bit */ 14 12 rc_dp initial("010101"b), /* def section */ 14 13 rc_s initial("010110"b), /* symbol segment */ 14 14 rc_ns initial("010111"b), /* negative symbol */ 14 15 rc_is18 initial("011000"b), /* internal static 18 */ 14 16 rc_is15 initial("011001"b), /* internal static 15 */ 14 17 rc_lb initial("011000"b), /* link block */ 14 18 rc_nlb initial("011001"b), /* negative link block */ 14 19 rc_sr initial("011010"b), /* self relative */ 14 20 rc_e initial("011111"b)) /* escape */ 14 21 bit(6) int static options(constant); 14 22 14 23 /* END INCLUDE FILE relocation_bits.incl.pl1 */ 12 37 12 38 12 39 12 40 a_data_type = data_type; 12 41 a_value = value; 12 42 12 43 if a_data_type = char_mode | a_data_type <= 0 | a_data_type > hbound(data_type_size,1) 12 44 then do; 12 45 call print_message(452, ltrim(char(decimal(a_data_type,12)))); /* cannot create the node */ 12 46 end; 12 47 else data_size = data_type_size(a_data_type); 12 48 12 49 if data_size = 1 12 50 then do; 12 51 mod_2_sum = v_array(1); 12 52 v_array(2) = "0"b; 12 53 end; 12 54 else mod_2_sum = bool(v_array(1),v_array(2),"0110"b); 12 55 12 56 12 57 hash_index = mod(binary(mod_2_sum,35),hash_table_size); 12 58 12 59 /* Search the hash table for the constant. */ 12 60 12 61 node_offset = hash_table(hash_index); 12 62 do while(node_offset > 0); /* search the entire bucket */ 12 63 node_ptr = addr(x(node_offset)); 12 64 12 65 if node_ptr -> constant.value = a_value /* must be same value */ 12 66 then if node_ptr -> node.data_type = a_data_type /* and same data type */ 12 67 then return(node_offset); 12 68 12 69 node_offset = node_ptr -> node.hash_chain; /* NB - pointer remains pointing at last item in bucket */ 12 70 end; 12 71 12 72 /* a new constant node must be created */ 12 73 12 74 node_offset = create_node(constant_node, size(constant)); 12 75 12 76 if hash_table(hash_index) = 0 /* Is this the first item in the bucket? */ 12 77 then hash_table(hash_index) = node_offset; /* yes */ 12 78 else node_ptr -> node.hash_chain = node_offset; /* no, add it to the end */ 12 79 12 80 node_ptr = addr(x(node_offset)); 12 81 node_ptr -> constant.data_type = a_data_type; 12 82 node_ptr -> constant.operand_type = constant_type; 12 83 node_ptr -> constant.is_addressable = "1"b; 12 84 node_ptr -> constant.reloc = rc_t; 12 85 node_ptr -> constant.value = a_value; 12 86 12 87 constant_info(data_size).constant_count = constant_info(data_size).constant_count + 1; 12 88 12 89 if constant_info(data_size).first_constant = 0 /* Is this the first item of this size? */ 12 90 then constant_info(data_size).first_constant = node_offset; /* yes */ 12 91 else addr(x(constant_info(data_size).last_constant)) -> constant.next_constant = node_offset; /* no, add it */ 12 92 12 93 constant_info(data_size).last_constant = node_offset; 12 94 12 95 return(node_offset); 12 96 12 97 end create_constant; 12 98 12 99 /* END fort_utilities.incl.pl1 */ 83 84 85 code_generator: 86 procedure (); 87 88 /****^ Written: 1 February 1976 by Richard A. Barnes 89* 90* 91*Modified: 31 Mar 90, SH - 508: When necessary, reset pr4 to linkage ptr. 92* Avoid inserting an instruction in the middle of the scm arg sequence 93* for index intrinsic when pr4 is valid. Also, remove "restore_prs". 94*Modified: 16 Oct 86, AG - 502a: Change make_symbol_descriptor so it always 95* generates correctly formatted char (*) descriptors. Change 96* make_entry_descriptor so it never "adjusts" incorrectly formatted 97* char (*) descriptors. Change get_param_char_size so that it always 98* expects correctly formatted char (*) descriptors. 99*Modified: 22 Sep 86, AG - 502: Set descriptor size field to "1"b only for 100* character *(*) variables in make_entry_descriptor. 101*Modified: 22 Sep 86, AG - 496a: Oops -- forgot that array symbols can 102* be accessed directly in "call" statements. Explicitly check 103* for symbol.dimensioned when restoring symbol.address.offset. 104*Modified: 04 Sep 86, AG - 496: For non-array symbols in very large common, 105* use symbol.addr_hold instead of symbol.address.offset to hold the 106* offset in the linkage section of the pointer to the symbol. Too 107* much code counts on symbol.address.offset holding the offset from 108* the pointer of the symbol (always 0). Also made create_storage_entry 109* save info in a_name about symbols used in create_entry structures. 110*Modified: 08 Jul 86, AG - 449.a: Use "anq/stq" instructions rather than "orsq" 111* to update length field in character* (*) dummy arg descriptors. 112*Modified: 19 Feb 86, BW & AG - 473.a: Flag error if passing VLA type arguments 113* to non-VLA type arguments in the same compilation unit. 114*Modified: 03 Feb 86, SH - 425: Passing hollerith (i.e. character) constant 115* data types as arguments to other data types will no longer 116* produce error 401 (inconsistent argument types). 117*Modified: 29 Oct 85, BW - 411: Make sure common block units are the same when 118* comparing maximum lengths. 119*Modified: 08 Aug 85, BW - 430: Prevent emission of deallocation code for auto- 120* matic LA's and VLA's when they don't exist in the compilation unit. 121*Modified: 02 Aug 85, BW - 463: Remove code for action (56) since the macros 122* no longer require this action after the bug fix. 123*Modified: 04 Jul 85, BW - 460: Fix addressing of complex number arrays. 124*Modified: 21 May 85, BW - 455: Ensure auto ptrs to parameters are allocated 125* on even word boundaries. 126*Modified: 24 Apr 85, MM - 449: Create the routine 'make_entry_descriptor' as 127* 'make_symbol_descriptor' can't be used by the code that makes 128* entrys. 129*Modified: 30 Jan 85, MM - 447: Allow base_man_load_any_pr to set the bit 130* address_in_base for VLA elements. 131*Modified: 19 Oct 84, MM - 443: Fix list_init_ array initialization. 132*Modified: 22 Aug 84, HH - 439: 'make_symbol_descriptor' sets lower bound to 133* -2**35 if lower bound is constant but upper bound is not. 134*Modified: 22 Jun 84, MM - Install typeless functions support. 135*Modified: 09 Apr 84, MM - 417: character elements are incorrectly assumed to 136* be word aligned in ansi77 mode if lower bound of array is 0. 137*Modified: 04 Apr 84, HH - 416: 'add' and 'sub' need to support -ve constants. 138*Modified: 28 Mar 84, HH: Install HFP support. 139*Modified: 13 Mar 84, HH - 415: Incorrect relocation information generated for 140* entry point declarations. 141*Modified: 26 Jan 84, TO: 414 - Fix bug in char(*) sizing introduced by entry 142* definition code. We need to emit an extra constant word for char(*) 143* descriptors, rather than mangle the real word that ORQ will refer to. 144*Modified: 19 Sep 83, RG & MM - 242/370: Use entry-defined arg_desc if one exists. 145*Modified: 27 Jul 83, HH - 371: 'mult' needs to support -ve constants. 146*Modified: 17 Jun 83, HH - 383: Simplify input to 'check_parameters'. 147*Modified: 8 June 83, TO: 382 - Fix size of entry_info (builtin(8)) to 148* correspond to reality (it is 7 words long). 149* Update documentation of builtin (8). 150*Modified: 8 June 83, TO: 381 - Fix register reservation mask for shorten_stack 151* renamed from reserve_pr1_mask (which reserved pr0 instead) to 152* shorten_stack_mask which reserves pr1, x1. 153*Modified: 14 April 83, RG: 377 - Fix flush_ref to use flag 'in_equiv_stmnt' 154* not 'aliasable'. 155*Modified: 14 April 83, TO - fix 'make_create_entry' to correctly address 156* 'create_entry.next' when setting 't' relocation. 157*Modified: 5 April 83, TO - fix 'check_parameters' to ensure parameter is 158* a symbol and not a return constant. 159*Modified: 5 April 83, TO - fix list_template_init of common bugs. 160*Modified: 5 April 83, TO - fix 'allocate', 'free' bug in VLA common 161* cleanup, have cleanup done by common cleanup routine. Chain headers 162* were being free'd twice, and cleanup during processing was 163* inconsistent. 164*Modified: 31 March 1983, TO: 374 - Fix bug in large_address array_ref in 165* finish_subscript in which the constant offset of the array_ref 166* backs up before the 16K bound, leaving array_ref base wrong and 167* large_address flag off preventing re-calc of base in 168* m_a_check_large_address. 169*Modified: 31 Jan 83, TO & HH: Install LA/VLA support. 170*Modified: 10 January 1982, TO - Add 'emit_entry_def (simple (56)) operation 171* from macros to create an entry definition entry. Added code to 172* gen_entry_defs to copy text position of definition to table. Added 173* code to 'check_parameters' (simple (15)) to fill in descriptors. 174*Modified: 31 December 1982, TO: 367 - Cause allocation of named constants if 175* we want a symbol_table. 176*Modified: 22 Dec 82, TO - 358: use 'lock_base' in 'load_preg' to correct 177* running out of pointer registers. 178*Modified: 18 Dec 82, TO - Add '-long_profile' support. 179*Modified: 17 Nov 82, HH - 361: 'get_format_var' operator no longer exists. 180*Modified: 05 August 1982, HH - Fix bug 357: Pad char constants with spaces 181* rather than NUL's. 182*Modified: 16 July, 1982, TO - fix bug introduced in fix of bug345. We 183* incorrectly mixed the index of the global and free register in 184* "base_man_load_large_base". 185*Modified: 21 May 1982, TO - Fix bug in check_arg_list where 'n' is used in 186* place of 'num_args'. 187*Modified: 20 May 1982, TO - Fix bug where virtual_origin automatic is not 188* allocated for star_extent array in 'get_array_size'. 189*Modified: 20 May 1982, TO - Fix descriptor bug where char*(*) multiplier is 190* only calculated for last dimension, leaving an unprobe-able, and at 191* times (dims>2) unrunnable binary. 192*Modified: 20 May 1982, TO - Fix probe bug where char*(*) multiplier calculated 193* for descriptor in bits is used for probe runtime_symbol in chars. 194* This causes an extended descriptor to be allocated in the stack and 195* the intermediate character multiplier to be stored in the extended 196* area to be picked up by runtime_symbol.bound(n).multiplier. 197*Modified: 9 May 1982, TO - Fix (if unless)_negative to know about other than 198* integer. 199*Modified: 7 May 1982, TO - Fix use of EAQ register and move_logical_to_a. 200* previously move_logical_to_a used and reset A, but didn't consider 201* those things in EAQ, which subsiquently got lost and not stored. 202*Modified: 5 May 1982, TO - Allocate char_star_function return_value. 203*Modified: 5 May 1982, TO - Add action (74) (if unless)_char_star_function. 204*Modified: 5 May 1982, TO - Add action (75) (if unless)_check_multiply. 205*Modified: 26 April 1982 , TO - fix navytest3 bug. Cause flush_ref to 206* remove ALL equivalenced refs in this chain. 207*Modified: 26 April 1982 , TO - fix navytest16 bug in optimized_subscript. 208* char_num of array base was not added to calculated character number. 209*Modified: 15 April 1982 , TO - Implement extended information for stack and 210* linkage overflow message (error 414). 211*Modified: 12 April 1982 , TO - Fix bug 344, stack_indirect in set_itp_addr. 212*Modified: 05 April 1982 , TO - Fix register reservation in argument and descriptor processing. 213*Modified: 15 September 1981, CRD - Change check_comparisons_and_increments to 214* put left shift on operator list of loop entry statement if back 215* target does not fall through. 216*Modified: 17 June 1981, CRD - Fix bug 322. 217*Modified: 12 May 1981, CRD - Add equiv_op, not_equiv_op. 218*Modified: 23 April 1981, CRD - Fix bug 319. 219*Modified: 20 April 1981, CRD - Fix bug 316. 220*Modified: 19 March 1981, CRD - Fix bug 311. 221*Modified: 12 March 1981, CRD - Implement assumed size arrays. 222*Modified: 27 February 1981, CRD - Implement array lower bounds ^= 1. 223*Modified: 9 December 1980, CRD - Change upper bound of 224* operator_table array to 102 for block_if, else_if, and 225* else operators. 226*Modified: 25 November 1980, CRD - Improve fix to bug 289. 227*Modified: 19 November 1980, CRD - Fix bug in which star extent arrays 228* did not have their virtual_origin and array_size symbols 229* set properly unless the first dimension was variable. 230* Also fixed bug in which an attempt to use an ITP argument 231* list was made when passing descriptors. 232*Modified: 31 October 1980, CRD - Change propagate_and_eliminate_assignment 233* not to eliminate assignments if the RHS is a symbol and is 234* subsequently set in the flow unit. This fixes bug 289. 235*Modified: 22 October 1980, CRD - Change load to call move_logical_to_a 236* unless the Q is being loaded. This fixes bug 288. 237*Modified: 6 October 1980, CRD - Change flush_ref to restore the 238* address of aligned character strings. This fixes bug 282. 239* Also some changes mandated by audit. Also moved symbolic 240* names of instructions in single_inst array to the include 241* file fort_single_inst_names.incl.pl1. 242*Modified: 24 September 1980, CRD - Add pointer register 1 to the pool 243* of registers available for addressing, etc. 244*Modified: 24 September 1980, CRD - Change desc_ptr_in_base to be a 245* simple macro (desc_ptr_in_pr3), and add arg_ptr_in_pr1. 246*Modified: 23 September 1980, CRD - Make refresh_regs refresh pointer 247* registers with zero offsets first. 248*Modified: 16 September 1980, CRD - Remove code in optimized_subscript 249* which bumped ref counts of length and offset temporaries. 250* Also changed drop_count to ignore operand offsets <= 0. 251*Modified: 15 August 1980, CRD - Fix large address bug in 252* continue_cat. 253*Modified: 13 August 1980, CRD - Catch negative length substrings. 254*Modified: 12 August 1980, CRD - Fix bug in (if unless)_ansi77. 255*Modified: 30 July 1980, CRD - Add code to avoid redundant virtual 256* origin computation. 257*Modified: 28 July 1980, CRD - Change optimized_subscript to deal 258* with named constants. Also change convention for detecting 259* unprocessed array_ref nodes to use array_ref.has_address. 260*Modified: 22 July 1980, CRD - Fix bug in optimized_subscript. 261*Modified: 16 July 1980, CRD - Add (if unless)_variable_arglist macro. 262*Modified: 15 July 1980, CRD - Changes for generating descriptors 263* on calls - copy needs_descriptors bit from entry_point 264* symbol to external symbol in assign_storage, and add 265* set_needs_descriptors macro. 266*Modified: 23 June 1980, CRD - Add (if unless)_ansi77. 267*Modified: 17 June 1980, CRD - Change assign_address_to_temp to copy 268* over length information, and to properly extract addresses 269* for dynamic temporaries. 270*Modified: 21 April 1980, CRD - Implement concatenation. 271*Modified: 18 April 1980, RAB - fix an ureported bug in which load_preg 272* loads a global value into a register that should have been 273* avoided. 274*Modified: 18 March 1980, RAB - fix a bug in which 275* check_comparisons_and_increments was calling connect_expression with 276* the order of the last 2 arguments reversed. This caused a strange 277* instability in temporary allocation, although the code was correct. 278*Modified: 9 March 1980, RAB - fix a bug in reset_scan: the processing 279* that occurs if we have passed over flow_units from other 280* loops should occur before we check to see if this loop is 281* finished. 282*Modified: 9 March 1980, RAB - fix several bugs: make free_temp 283* zero temporary.globally_assigned; have reset_scan not 284* call save_state if the statement is referenced by assign 285* or referenced backwards; have reset_scan discard the 286* machine_state at the end of the loop. 287*Modified: 7 March 1980, RAB - fix a bug in load_preg. It 288* should worry about avoiding prs in next_lp not cur_lp. 289*Modified: 6 March 1980, RAB - fix a bug in merge_state. In order 290* to refresh the global bits when the state is discarded, 291* merge_state should call refresh_global_bits rather than 292* enter_loop, since lp_msp might be null. 293*Modified: 24 February 1980, RAB - add floating_power_of_two 294*Modified: 15 February 1980, CRD - change return macro to allow 295* returning operands other than temporaries. 296*Modified: 9 February 1980, RAB - allow variables busy_on_exit from a 297* loop to be kept in an index register. 298*Modified: 8 February 1980, CRD - Add char1_to_int, int_to_char1, 299* and (if unless)_aligned macros; fix text_ref to work 300* with char constants; and change the return macro to 301* convert counts to integer constants. 302*Modified: 3 February 1980, CRD - add code to support star extent 303* character strings, to support Fortran entries which require 304* descriptors, and to implement substrings. 305*Modified: 30 January 1980, RAB - to fix a bug in which an empty 306* globally assigned register was erroneously loaded with 307* a local value. The fix involved adding an argument to 308* get_free_reg to distinguish between a register preselected 309* because it was globally assigned the desired item and 310* a register preselected because it was empty. 311*Modified: 27 January 1980, RAB - add force_ql macro to improve jump_computed 312* code. 313*Modified: 8 January 1980, RAB -alter reset_subprogram to reset temporaries in 314* ALL loops. 315*Modified: 8 January 1980, RAB - fix reference count bugs in gen_itp_list and 316* base_man_load_pr. 317*Modified: 2 January 1980, RAB - fix a bunch of bugs. 318*Modified: 1 January 1980, RAB - added propagate_and_eliminate_assignment. 319* Also, loop.all_xrs_globally_assigned. 320*Modified: 28 December 1979, RAB - made changes to prevent trouble if 321* more than one register were locked for arguments to pl1_operators; 322* implemented refresh_regs_if_next_is_jump macro to allow 323* refresh_regs before relational operator; implemented 324* note_eligible_ind_var_use to allow the counting of an 325* incrementing or comparison as an index register use during 326* analysis; made changes to allow all registers of a class 327* to be globally assigned if there are no local uses and 328* there are enough registers to assign all global items; and 329* made changes to force doubleword alignment for all innermost 330* loops. Also, removed reset_regs. 331*Modified: 22 December 1979, RAB - make round of bugfixes to register optimizer. 332*Modified: 18 December 1979, RAB - make bulk of changes to implement 333* the REGISTER OPTIMIZER!! 334*Modified: 1 December 1979, RAB - change ERROR to not push an error 335* operand for the scan frame as this is wrong for the 336* optimizing cg. 337*Modified: 30 November 1979, RAB - to add second set of changes for 338* the register optimizer. 339*Modified: 3 November 1979, RAB - to add first set of changes for 340* the register optimizer. 341*Modified: 31 October 1979, CRD - fix bugs caught by audit, and add 342* code to get_param_array_size to fill in descriptors for 343* packed character string correctly. 344*Modified: 29 October 1979, CRD - add register reservation for the 345* A and Q for EIS instruction offsets. 346*Modified: 25 October 1979, CRD - invent make_both_addressable, and 347* change emit_eis to call it. Invent eaq_man_load_a_or_q, 348* and change m_a to call it. Invent a new eaq name, in_ia, 349* for integers in the A register. 350*Modified: 23 October 1979, CRD - assorted changes to allow the code 351* generator to be compiled with subscriptrange enabled; and a 352* bug fix to allow the load macro to handle counts properly. 353*Modified: 17 October 1979, CRD - changes due to audit and enlightenment. 354*Modified: 5 October 1979, CRD - change EAQ management to consider 355* the EAQ to be four registers. 356*Modified: 20 September 1979, CRD - added code in base_man_load_pr 357* to load addresses of unaligned character strings. 358*Modified: 19 September 1979, CRD - change register reservation to 359* use logic planned for register optimizer. 360*Modified: 12 September 1979, CRD - change large address scheme to 361* use full 32K addressing capability of 15 bit offset. 362*Modified: 5 September 1979, CRD - make changes to storage allocator 363* for ANSI 77 character mode. 364*Modified: 28 August 1979, CRD - fix bug 233 (%options round and 365* %options truncate in the same compilation don't work). 366*Modified: 24 August 1979, CRD - fix bug 232, in which descriptors 367* are copied onto the stack incorrectly due to the data_type 368* field of symbols created by the CG not being set. 369*Modified: 23 August 1979, CRD - move code to build runtime symbol 370* table to separate external procedure, fort_make_symbol_table. 371*Modified: 6 August 1979, RAB - fix 230 (FATAL ERROR 418 in free_regs for large stackframes) 372*Modified: 25 July 1979, CRD - rearrange more simple macro 373* instructions to have opcodes in the left half. 374*Modified: 24 July 1979, CRD - fix bug 229, in which parent chain 375* of runtime symbol table was being built incorrectly. 376*Modified: 23 July 1979, CRD - compress the opcodes for certain 377* if/unless macro pairs into a single opcode by using 378* macro_cond_inst.if_test. 379*Modified: 23 July 1979, CRD - put op codes of simple macro 380* instructions in the left half of the instruction word. 381*Modified: 16 July 1979, CRD - changes parallel to those made to 382* ext_code_generator in fixing bug 225. 383*Modified: 11 June 1979, RAB fix bug 209 (temp space not being reused) 384*Modified: 2 May 1979, RAB - (1) Change scheme for addresses >= 16K to use ptr 385* regs instead of xregs; (2) Change action of OPT_SUBSCRIPT to NEVER 386* create temps (xr_man now calls a subroutine of m_a to get the 387* address of nonaddressable operands) fixing bug 203; and (3) Change 388* get_free_reg to get usage counts of temps by following input_to chain 389* and adding ref_counts of array_refs. 390*Modified: 17 January 1979, RAB - to speed up reg management by using 391* machine_state.value_in_xr. 392*Modified: 5 January 1979, RAB - to make get_free_reg use ref_counts 393* in deciding which register to flush, and to improve the 394* > 16k case for array elements. 395*Modified: 6 December 1978, PES - for %options and %global. 396*Modified: 4 December 1978, RAB - for option to initialize auto storage to zero 397*Modified: 01 December 1978, RAB - Improve handling of round before compare. 398*Modified: 30 November 1978, PES - Key rounding off of fortran_options. 399*Modified: 19 November 1978, RAB - Centralize control of rounding 400* by use of eaq.rounded. 401*Modified: 25 October 1978, PES -Changes for larger common blocks and arrays. 402*Modified: 11 October 1978, RAB - Fix bug 184 in which bad code is 403* produced if an increment causes an address to cross a 16K 404* boundary. Also checks were put in for invalid data_type 405* and operand_type fields and for uninitialized 406* array_ref nodes. 407*Modified: 12 Sept 1978, PES - Move PS from static to automatic storage, to fix 408* bug 182 in which fortran_io_ fails in the event of a segment loop, 409* e.g. a subr in segment calls a subr in segment , which in 410* turn calls another subr in segment . 411*Modified: 06 Sept 1978, PES - Fix (masked) bug which might cause a register not 412* to be reloaded before being used as an index, even if the value has 413* been changed in storage. This bug is in a currently unused block of 414* code, but future changes could cause it to surface. 415*Modified: 27 July 1978, PES - Fix bug in handling of nested subscripts; fix bug 416* in setting of symbol.simple for parameters. 417*Modified: 23 June 1978, DSL - Fixes generated by audit. Allocate ps as first 418* thing in static in order to prevent problems if ps overlaps 16K 419* boundary; some speed up changes; add machine state ref count 420* (temporary.ms_ref_count) to handle temp node's second purpose, place 421* holding in machine states; temporary's storage is freed when normal 422* ref count is zero; temporary is only freed if ms_ref_count is zero 423* too. Fix ref count bug in emit_eis; set symbol.element_size for 424* descriptors generated by code generator. 425* 426* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 427* 428*Rewritten starting 9 November 1977 by David S. Levin to create the optimizing code generator. 429* 430* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 431* 432*Modified: 4 November 1977, DSL - Use maximum length when allocating common 433* blocks. 434*Modified: 31 October 1977, RAB - Fix bug 129 where large virtual origins get 435* bad code. Also, implement DL modification for negative constants. 436*Modified: 6 October 1977, DSL - Fix bug in subscripting code for the following: 437* array i(3,3),j(3); i(j(l), l) = m(l) 438*Modified: 30 August 1977, DSL - coordinated change with listing generator to 439* mark entry "data" words; base_man_load_pr_value fails to set reloc 440* info and symbol info; multiply macro does not check for product > 441* bias. Fix "load" to set proper ref count for complex vars. 442* NOTE -- in this compilation the value of bias changed from 65536 to 443* 131072. 444*Modified: 21 July 1977, DSL - fix bug in itp list reloc info. 445*Modified: 14 July 1977 by DSL - 1) add new builtin, ps_area_ptr, for open and 446* close; 2) add new macro load_pr_value, to load a pr with the contents 447* of a location; 3) give relocation info for automatic storage template 448* (bug fix). 449*Modified: 5 July 1977 by DSL - 1) fort_system_constants.incl.pl1 change; 450* 2) print message for multiple initialization of a single common 451* block. 3) Change if_ind and unless_ind to always work even if the 452* eaq appears empty, fixing 108. THIS CONFLICTS WITH PUBLISHED 453* DOCUMENTATION !!! 454*Modified: 26 May 1977 by DSL to always generate ERROR operand if an error 455* occurs in a function frame; THIS CHANGE EXACTLY CONFLICTS WITH THE 456* ORIGINAL DOCUMENTATION OF THE MACRO LANGUAGE. Refer to code for 457* action 66 (error) for complete details. 458*Modified: 3 May 1977 by RAB for store macro. 459*Modified: 28 April 1977 by DSL - for new fort_system_constants.incl.pl1 460*Modified: 28 March 1977 by DSL for new stmnt label handling; interface with new 461* node formats; recompile because of PL/I bug 1599 (in compile_link for 462* A$B common names). 463*Modified: Feb 1977 by GDC for the optimizer 464*Modified: 31 Jan 1977 by DSL to allow type-3 links for common block names of 465* the form a$. 466*Modified: 9 Dec 1976 by DSL to reference fort_version_info$version_name 467*Modified: 7 Dec 1976 by RAB to fix bugs in make_symbol_table 468*Modified: 22 Nov 1976 by RAB to add -profile 469*Modified: November 1976 by David Levin to add make_symbol_table 470*Modified: 19 Oct 1976 by RAB for ok_lists and runtime symbol table hooks 471*Modified: 14 Oct 1976 by RAB for relocation bits 472*Modified: 7 Oct 1976 by RAB for optional descriptors 473*Modified: 30 Sept 1976 by RAB for object listings and local object, operand, 474* and polish bases 475*Modified: 5 July 1976 by RAB for addrs >= 16K 476* 477*END Modifications */ 478 479 dcl first_frame ptr; 480 481 dcl next_free_ms ptr; /* free chain of machine state nodes in the operand region */ 482 483 dcl cleanup_body_address fixed bin (18) unsigned; 484 dcl alloc_auto_cleanup bit (1) aligned; 485 486 dcl (c, lib_pt, p) ptr; 487 488 dcl (n, text_pos, link_pos, def_pos, sym_pos, begin_links, linkrel, defrel, symrel, lib_pos, last_pos, profile_start, 489 profile_pos) fixed bin (18); 490 491 dcl (begin_external_list, end_external_list) fixed bin (18); 492 493 dcl begin_forward_refs fixed bin (18); 494 495 dcl (first_namelist, last_namelist) fixed bin (18); 496 dcl (first_header, last_header) ptr init (null ()); /* header chain */ 497 498 dcl (link_base, def_base, lib_list_ptr, a_base, parm_desc_ptrsp) ptr; 499 dcl (link_reloc_base, def_reloc_base, lib_reloc_ptr) ptr; 500 501 502 dcl free (2:4) ptr; /* free chains of optimizer nodes */ 503 dcl freei ptr; /* .. */ 504 505 dcl (generate_long_profile, generate_profile, generate_symtab, assembly_list, do_rounding, init_auto_to_zero) 506 bit (1) aligned; 507 508 dcl builtins (0:11) fixed bin (18); /* format: off */ 509 /* builtins are: 510* 0: zero integer zero constant 511* 1: one integer one constant 512* 2: ps symbol for fortran I/O arglist 513* 3: auto_template Initialization template for auto storage 514* 4: auto_overlay array reference overlay of automatic storage 515* 5: null_ptr initialized to a null pointer value 516* 6: null value of 0 as a null 517* 7: two integer two constant 518* 8: entry_info place to store quick proc info 519* word 0 - Return address pointer (ITS). 520* word 2 - Argument pointer (ITS). 521* word 4 - Descriptor pointer (ITS). 522* word 6 - Permanent Stack extension value (18-bit offset, 1 word). 523* 9: star_symbol <*symbol>|0 524* 10: ps_area_ptr symbol for ps.buffer_p 525* 11: desc_overlay symbol for accessing a descriptor 526**/ 527 /* format: on */ 528 529 dcl image (amt) fixed bin (18) aligned based; 530 dcl char_image char (4 * amt) aligned based; 531 dcl (zero_def, last_def, seg_def) bit (18) aligned; 532 dcl def_pool (20) fixed bin (18); 533 534 dcl (amt, con, i, j, lib) fixed bin (18); 535 536 dcl rands (0:operand_max_len - 1) fixed bin (18) aligned based (operand_base); 537 538 dcl polish (0:polish_max_len - 1) fixed bin (18) aligned based (polish_base); 539 540 dcl a_name (0:261119 - 2 * (number_of_lines + 1)) fixed bin (18) aligned based (a_base); 541 542 dcl quad (0:quad_max_len - 1) fixed bin (18) aligned based (quadruple_base); 543 544 dcl opt (0:opt_max_len - 1) fixed bin (35) aligned based (opt_base); 545 546 dcl 1 external_list based (polish_base) aligned, 547 2 ext_ref (0:polish_max_len - 1) ptr unal; 548 549 dcl last_auto_loc fixed bin (18); 550 551 dcl linkage_pad fixed bin (18); /* linkage pad of LA and VLA pointers */ 552 dcl first_auto_var_loc fixed bin (18); 553 dcl free_temps (3) fixed bin (18); 554 dcl auto_template fixed bin (18); 555 556 dcl (hold_text_pos, hold_last_auto_loc) fixed bin (18); 557 558 dcl 1 text_halfs (0:262143) aligned based (object_base), 559 2 left fixed bin (17) unal, 560 2 right fixed bin (17) unal; 561 562 dcl 1 reloc_halfs (0:262143) aligned based (relocation_base), 563 2 left bit (18) unal, 564 2 right bit (18) unal; 565 566 dcl reloc (0:3) bit (36) aligned based; 567 568 dcl 1 forward_refs (0:next_free_polish - 1) based (polish_base) aligned, 569 2 instruction fixed bin (17) unal, 570 2 operand fixed bin (18) unsigned unal; 571 572 dcl vsegname char (32) varying defined (objectname); 573 574 dcl 1 saved_lib_list aligned based (lib_list_ptr), 575 2 nlibs fixed bin (18), 576 2 names (n refer (nlibs)), 577 3 offset bit (18) unal, 578 3 lng fixed bin (17) unal; 579 580 dcl 1 saved_lib_reloc_list aligned based (lib_reloc_ptr), 581 2 mlibs fixed bin (18), 582 2 names (n), 583 3 reloc bit (18) unal, 584 3 pad bit (18) unal; 585 586 dcl 1 parm_desc_ptrs aligned based (parm_desc_ptrsp), 587 2 n_args fixed bin (18) unaligned unsigned, 588 2 descriptor_relp (0 refer (parm_desc_ptrs.n_args)) fixed bin (18) unsigned unaligned; 589 590 591 dcl segname char (32) aligned; 592 593 dcl bases (0:7) bit (3) aligned internal static options (constant) 594 initial ("0"b3, "4"b3, "1"b3, "2"b3, "3"b3, "5"b3, "7"b3, "6"b3); 595 596 dcl ( 597 ap defined (bases (0)), 598 ab defined (bases (2)), 599 bp defined (bases (3)), 600 bb defined (bases (4)), 601 lp defined (bases (1)), 602 lb defined (bases (5)), 603 sp defined (bases (7)), 604 sb defined (bases (6)) 605 ) bit (3) aligned; 606 607 dcl which_base (0:7) fixed binary (3) internal static options (constant) initial (0, 2, 3, 4, 1, 5, 7, 6); 608 609 dcl ( 610 INDEX init (1), 611 BASE init (2) 612 ) fixed bin int static options (constant); 613 614 dcl ( 615 DU_mod initial ("03"b3), 616 DL_mod initial ("07"b3), 617 AL_mod initial ("05"b3), 618 AU_mod initial ("01"b3), 619 QL_mod initial ("06"b3), 620 QU_mod initial ("02"b3), 621 X0_mod initial ("10"b3), 622 X1_mod initial ("11"b3), 623 RI_mod initial ("20"b3), 624 ITP_mod initial ("41"b3), 625 FT2_mod initial ("46"b3) 626 ) bit (6) aligned internal static options (constant); 627 628 dcl 01 descriptor_type_word (0:1, 7) aligned, 629 02 flag bit (1) unaligned init ((14) ("1"b)), 630 02 type fixed bin (6) unsigned unaligned 631 init (ft_integer_dtype, ft_real_dtype, ft_double_dtype, ft_complex_dtype, ft_logical_dtype, ft_char_dtype, 632 ft_external_dtype, ft_integer_dtype, ft_hex_real_dtype, ft_hex_double_dtype, ft_hex_complex_dtype, 633 ft_logical_dtype, ft_char_dtype, ft_external_dtype), 634 02 packed bit (1) unaligned init ((14) ("0"b)), 635 02 number_dims fixed bin (3) unaligned init ((14) 0), 636 02 size fixed bin (23) unaligned init ((2) (35, 27, 63, 27, 1, 0, 0)); 637 dcl fptype fixed bin (1) init (bin (shared_globals.hfp, 1)); 638 639 dcl ext_base_on bit (36) aligned internal static options (constant) initial ("000000000100"b3); 640 641 dcl max_address_offset fixed bin (14) static options (constant) init (16383); 642 dcl max_linkage_size fixed binary (18) internal static options (constant) initial (131071); 643 dcl max_stack_size fixed bin (18) int static init (62000) options (constant); 644 645 dcl (abs, addr, addrel, bin, binary, bit, bool, byte, char, cleanup, copy, 646 currentsize, divide, fixed, hbound, index, lbound, ltrim, max, min, mod, 647 null, ptr, rank, rel, reverse, size, string, substr, unspec, verify) builtin; 648 15 1 /* BEGIN INCLUDE FILE linkdcl.incl.pl1 --- last modified 15 Nov 1971 by C Garman */ 15 2 15 3 /* Last Modified (Date and Reason): 15 4* 6/75 by M.Weaver to add virgin_linkage_header declaration 15 5* 6/75 by S.Webber to comment existing structures better 15 6* 9/77 by M. Weaver to add run_depth to link 15 7* 2/83 by M. Weaver to add linkage header flags and change run_depth precision 15 8**/ 15 9 15 10 /* format: style3 */ 15 11 dcl 1 link based aligned, /* link pair in linkage section */ 15 12 2 head_ptr bit (18) unal, /* rel pointer to beginning of linkage section */ 15 13 2 ringno bit (3) unal, 15 14 2 mbz bit (6) unal, 15 15 2 run_depth fixed bin (2) unal, /* run unit depth, filled when link is snapped */ 15 16 2 ft2 bit (6) unal, /* fault tag. 46(8) if not snapped, 43(8) if snapped */ 15 17 2 exp_ptr bit (18) unal, /* pointer (rel to defs) of expression word */ 15 18 2 mbz2 bit (12) unal, 15 19 2 modifier bit (6) unal; /* modifier to be left in snapped link */ 15 20 15 21 dcl 1 exp_word based aligned, /* expression word in link definition */ 15 22 2 type_ptr bit (18) unal, /* pointer (rel to defs) of type pair structure */ 15 23 2 exp bit (18) unal; /* constant expression to be added in when snapping link */ 15 24 15 25 dcl 1 type_pair based aligned, /* type pair in link definition */ 15 26 2 type bit (18) unal, /* type of link. may be 1,2,3,4,5, or 6 */ 15 27 2 trap_ptr bit (18) unal, /* pointer (rel to defs) to the trap word */ 15 28 2 seg_ptr bit (18) unal, /* pointer to ACC reference name for segment referenced */ 15 29 2 ext_ptr bit (18) unal; /* pointer (rel to defs) of ACC segdef name */ 15 30 15 31 dcl 1 header based aligned, /* linkage block header */ 15 32 2 def_ptr ptr, /* pointer to definition section */ 15 33 2 symbol_ptr ptr unal, /* pointer to symbol section in object segment */ 15 34 2 original_linkage_ptr 15 35 ptr unal, /* pointer to linkage section in object segment */ 15 36 2 unused bit (72), 15 37 2 stats, 15 38 3 begin_links bit (18) unal, /* offset (rel to this section) of first link */ 15 39 3 block_length bit (18) unal, /* number of words in this linkage section */ 15 40 3 segment_number 15 41 bit (18) unal, /* text segment number associated with this section */ 15 42 3 static_length bit (18) unal; /* number of words of static for this segment */ 15 43 15 44 dcl 1 linkage_header_flags 15 45 aligned based, /* overlay of def_ptr for flags */ 15 46 2 pad1 bit (28) unaligned, /* flags are in first word */ 15 47 2 static_vlas bit (1) unaligned, /* static section "owns" some LA/VLA segments */ 15 48 2 perprocess_static 15 49 bit (1) unaligned, /* 1 copy of static section is used by all tasks/run units */ 15 50 2 pad2 bit (6) unaligned; 15 51 15 52 dcl 1 virgin_linkage_header 15 53 aligned based, /* template for linkage header in object segment */ 15 54 2 pad bit (30) unaligned, /* is filled in by linker */ 15 55 2 defs_in_link bit (6) unaligned, /* =o20 if defs in linkage (nonstandard) */ 15 56 2 def_offset bit (18) unaligned, /* offset of definition section */ 15 57 2 first_ref_relp bit (18) unaligned, /* offset of trap-at-first-reference offset array */ 15 58 2 filled_in_later bit (144), 15 59 2 link_begin bit (18) unaligned, /* offset of first link */ 15 60 2 linkage_section_lng 15 61 bit (18) unaligned, /* length of linkage section */ 15 62 2 segno_pad bit (18) unaligned, /* will be segment number of copied linkage */ 15 63 2 static_length bit (18) unaligned; /* length of static section */ 15 64 15 65 15 66 dcl 1 trap_word based aligned, /* trap word in link definition */ 15 67 2 call_ptr bit (18) unal, /* pointer (rel to link) of link to trap procedure */ 15 68 2 arg_ptr bit (18) unal; /* pointer (rel to link) of link to arg info for trap proc */ 15 69 15 70 dcl 1 name based aligned, /* storage of ASCII names in definitions */ 15 71 2 nchars bit (9) unaligned, /* number of characters in name */ 15 72 2 char_string char (31) unaligned; /* 31-character name */ 15 73 15 74 /* END INCLUDE FILE linkdcl.incl.pl1 */ 649 16 1 /* BEGIN INCLUDE FILE ... object_map.incl.pl1 */ 16 2 /* coded February 8, 1972 by Michael J. Spier */ 16 3 /* Last modified on 05/20/72 at 13:29:38 by R F Mabee. */ 16 4 /* Made to agree with Spier's document on 20 May 1972 by R F Mabee. */ 16 5 /* modified on 6 May 1972 by R F Mabee to add map_ptr at end of object map. */ 16 6 /* modified May, 1972 by M. Weaver */ 16 7 /* modified 5/75 by E. Wiatrowski and 6/75 by M. Weaver */ 16 8 /* modified 5/77 by M. Weaver to add perprocess_static bit */ 16 9 16 10 declare 1 object_map aligned based, /* Structure describing standard object map */ 16 11 16 12 2 decl_vers fixed bin, /* Version number of current structure format */ 16 13 2 identifier char (8) aligned, /* Must be the constant "obj_map" */ 16 14 2 text_offset bit (18) unaligned, /* Offset relative to base of object segment of base of text section */ 16 15 2 text_length bit (18) unaligned, /* Length in words of text section */ 16 16 2 definition_offset bit (18) unaligned, /* Offset relative to base of object seg of base of definition section */ 16 17 2 definition_length bit (18) unaligned, /* Length in words of definition section */ 16 18 2 linkage_offset bit (18) unaligned, /* Offset relative to base of object seg of base of linkage section */ 16 19 2 linkage_length bit (18) unaligned, /* Length in words of linkage section */ 16 20 2 static_offset bit (18) unaligned, /* Offset relative to base of obj seg of static section */ 16 21 2 static_length bit (18) unaligned, /* Length in words of static section */ 16 22 2 symbol_offset bit (18) unaligned, /* Offset relative to base of object seg of base of symbol section */ 16 23 2 symbol_length bit (18) unaligned, /* Length in words of symbol section */ 16 24 2 break_map_offset bit (18) unaligned, /* Offset relative to base of object seg of base of break map */ 16 25 2 break_map_length bit (18) unaligned, /* Length in words of break map */ 16 26 2 entry_bound bit (18) unaligned, /* Offset in text of last gate entry */ 16 27 2 text_link_offset bit (18) unaligned, /* Offset of first text-embedded link */ 16 28 2 format aligned, /* Word containing bit flags about object type */ 16 29 3 bound bit (1) unaligned, /* On if segment is bound */ 16 30 3 relocatable bit (1) unaligned, /* On if segment has relocation info in its first symbol block */ 16 31 3 procedure bit (1) unaligned, /* On if segment is an executable object program */ 16 32 3 standard bit (1) unaligned, /* On if segment is in standard format (more than just standard map) */ 16 33 3 separate_static bit(1) unaligned, /* On if static is a separate section from linkage */ 16 34 3 links_in_text bit (1) unaligned, /* On if there are text-embedded links */ 16 35 3 perprocess_static bit (1) unaligned, /* On if static is not to be per run unit */ 16 36 3 unused bit (29) unaligned; /* Reserved */ 16 37 16 38 declare map_ptr bit(18) aligned based; /* Last word of the segment. It points to the base of the object map. */ 16 39 16 40 declare object_map_version_2 fixed bin static init(2); 16 41 16 42 /* END INCLUDE FILE ... object_map.incl.pl1 */ 650 17 1 /* BEGIN INCLUDE FILE relbts.incl.pl1 */ 17 2 17 3 /* This include file defines the relocation bits as bit (18) entities. See 17 4* also relocation_bits.incl.pl1 and reloc_lower.incl.pl1. */ 17 5 17 6 dcl ( rc_a initial("0"b), /* absolute */ 17 7 rc_t initial("000000000000010000"b), /* text */ 17 8 rc_nt initial("000000000000010001"b), /* negative text */ 17 9 rc_lp18 initial("000000000000010010"b), /* linkage, 18 bit */ 17 10 rc_nlp18 initial("000000000000010011"b), /* negative link, 18 bit */ 17 11 rc_lp15 initial("000000000000010100"b), /* linkage, 15 bit */ 17 12 rc_dp initial("000000000000010101"b), /* def section */ 17 13 rc_s initial("000000000000010110"b), /* symbol segment */ 17 14 rc_ns initial("000000000000010111"b), /* negative symbol */ 17 15 rc_is18 initial("000000000000011000"b), /* internal static 18 */ 17 16 rc_is15 initial("000000000000011001"b), /* internal static 15 */ 17 17 rc_lb initial("000000000000011000"b), /* link block */ 17 18 rc_nlb initial("000000000000011001"b), /* negative link block */ 17 19 rc_sr initial("000000000000011010"b), /* self relative */ 17 20 rc_e initial("000000000000011111"b)) /* escape */ 17 21 bit(18) internal static options(constant); 17 22 17 23 dcl ( rc_dp_dp initial("000000000000010101000000000000010101"b), /* def section, def section */ 17 24 rc_a_dp initial("000000000000000000000000000000010101"b)) /* absolute, def section */ 17 25 bit(36) internal static options(constant); 17 26 17 27 /* END INCLUDE FILE relbts.incl.pl1 */ 651 18 1 /* BEGIN INCLUDE FILE reloc_lower.incl.pl1 */ 18 2 18 3 /* See relocation_bits.incl.pl1 and relbts.incl.pl1 for other declarations of 18 4* relocation information. */ 18 5 18 6 dcl ( rc_a_lp18 init("000000000000000000000000000000010010"b), 18 7 rc_a_is18 init("000000000000000000000000000000011000"b), 18 8 rc_a_t init("000000000000000000000000000000010000"b)) 18 9 bit(36) aligned int static options(constant); 18 10 18 11 /* END INCLUDE FILE reloc_lower.incl.pl1 */ 652 19 1 /* BEGIN INCLUDE FILE its.incl.pl1 19 2* modified 27 July 79 by JRDavis to add its_unsigned 19 3* Internal format of ITS pointer, including ring-number field for follow-on processor */ 19 4 19 5 dcl 1 its based aligned, /* declaration for ITS type pointer */ 19 6 2 pad1 bit (3) unaligned, 19 7 2 segno bit (15) unaligned, /* segment number within the pointer */ 19 8 2 ringno bit (3) unaligned, /* ring number within the pointer */ 19 9 2 pad2 bit (9) unaligned, 19 10 2 its_mod bit (6) unaligned, /* should be 43(8) */ 19 11 19 12 2 offset bit (18) unaligned, /* word offset within the addressed segment */ 19 13 2 pad3 bit (3) unaligned, 19 14 2 bit_offset bit (6) unaligned, /* bit offset within the word */ 19 15 2 pad4 bit (3) unaligned, 19 16 2 mod bit (6) unaligned; /* further modification */ 19 17 19 18 dcl 1 itp based aligned, /* declaration for ITP type pointer */ 19 19 2 pr_no bit (3) unaligned, /* number of pointer register to use */ 19 20 2 pad1 bit (27) unaligned, 19 21 2 itp_mod bit (6) unaligned, /* should be 41(8) */ 19 22 19 23 2 offset bit (18) unaligned, /* word offset from pointer register word offset */ 19 24 2 pad2 bit (3) unaligned, 19 25 2 bit_offset bit (6) unaligned, /* bit offset relative to new word offset */ 19 26 2 pad3 bit (3) unaligned, 19 27 2 mod bit (6) unaligned; /* further modification */ 19 28 19 29 19 30 dcl 1 its_unsigned based aligned, /* just like its, but with unsigned binary */ 19 31 2 pad1 bit (3) unaligned, 19 32 2 segno fixed bin (15) unsigned unaligned, 19 33 2 ringno fixed bin (3) unsigned unaligned, 19 34 2 pad2 bit (9) unaligned, 19 35 2 its_mod bit (6) unaligned, 19 36 19 37 2 offset fixed bin (18) unsigned unaligned, 19 38 2 pad3 bit (3) unaligned, 19 39 2 bit_offset fixed bin (6) unsigned unaligned, 19 40 2 pad4 bit (3) unaligned, 19 41 2 mod bit (6) unaligned; 19 42 19 43 dcl 1 itp_unsigned based aligned, /* just like itp, but with unsigned binary where appropriate */ 19 44 2 pr_no fixed bin (3) unsigned unaligned, 19 45 2 pad1 bit (27) unaligned, 19 46 2 itp_mod bit (6) unaligned, 19 47 19 48 2 offset fixed bin (18) unsigned unaligned, 19 49 2 pad2 bit (3) unaligned, 19 50 2 bit_offset fixed bin (6) unsigned unaligned, 19 51 2 pad3 bit (3) unaligned, 19 52 2 mod bit (6) unaligned; 19 53 19 54 19 55 dcl ITS_MODIFIER bit (6) unaligned internal static options (constant) init ("43"b3); 19 56 dcl ITP_MODIFIER bit (6) unaligned internal static options (constant) init ("41"b3); 19 57 19 58 /* END INCLUDE FILE its.incl.pl1 */ 653 20 1 /* BEGIN INCLUDE FILE profile_entry.incl.pl1 */ 20 2 20 3 dcl 1 profile_entry aligned based, 20 4 2 map bit(18) unaligned, 20 5 2 skip bit(18) unaligned, 20 6 2 count fixed bin; 20 7 20 8 /* END INCLUDE FILE profile_entry.incl.pl1 */ 654 21 1 /* BEGIN include file fortran_storage.incl.pl1 */ 21 2 21 3 /* Created 82-09-21 by T. Oke (UNCA) */ 21 4 21 5 /* Modification History: 21 6* 21 7*Modified: 1 October 1982, TO - add pointer_count and pointer entries. 21 8*Modified: 9 November 1982, TO - Move pointer_count, add common_link. 21 9**/ 21 10 21 11 /* Definitions of the structures controlling the creation of and initialization 21 12* lists for fortran_storage_driver. */ 21 13 21 14 /* For VLA entries there may be a number of pointers, each of which points to a 21 15* single VLA entity within the VLA. Each such pointer supplies an offset and 21 16* is stored by 'fortran_storage_'. 21 17* 21 18* For VLA COMMON, there is a pointer to the link in the linkage section. The 21 19* unsnapped link (which is in the template linkage section) supplies an offset 21 20* to find the expression_word in the definition section, which offsets to the 21 21* type_pair, which supplies the initialization information. */ 21 22 21 23 dcl 1 create_entry based, /* creation list entry */ 21 24 2 location fixed bin (18) unsigned unaligned, /* location of base */ 21 25 2 flags unaligned structure, 21 26 3 auto bit (1) unaligned, /* automatic storage entry */ 21 27 3 static bit (1) unaligned, /* static storage entry */ 21 28 3 common bit (1) unaligned, /* common storage entry */ 21 29 3 LA bit (1) unaligned, /* Large Array (255K) */ 21 30 3 VLA bit (1) unaligned, /* Very Large Array (>255K) */ 21 31 3 K256 bit (1) unaligned, /* alloc 256K segs */ 21 32 3 init bit (1) unaligned, /* initialized */ 21 33 3 pad bit (2) unaligned, /* FUTURE EXPANSION */ 21 34 3 pointer_count fixed bin (9) unsigned unaligned, /* number of pointers to fill in */ 21 35 2 length fixed bin (24) aligned, /* number of words required */ 21 36 2 next fixed bin (18) unsigned unaligned, /* offset to next create entry */ 21 37 2 name_length fixed bin (17) unaligned, /* size of block name field */ 21 38 2 common_link fixed bin (18) unsigned unaligned, /* location of link if COMMON */ 21 39 21 40 2 block_name char (0 refer (create_entry.name_length)), 21 41 2 pointer_offsets (0 refer (create_entry.pointer_count)) aligned, 21 42 3 pad bit (12) unaligned, 21 43 3 offset fixed bin (24) unsigned unaligned; 21 44 21 45 /* Pointers will be created for each VLA sub-entity, so the pointer_count field 21 46* indicates how many pointers follow the block_name. */ 21 47 21 48 21 49 21 50 21 51 /* Initialization data. The length and datum are bit items, to permit a wide 21 52* range of inputs. 21 53* 21 54* 1. A 'repeat' of '0' signifies skipping of 'length' bits. 21 55* 2. A 'length' of '0' signifies the last item of the list. 21 56* 21 57* COMMON, VLA's, and LA's, are presumed to start at the base pointer of their 21 58* particular storage section. */ 21 59 21 60 21 61 dcl 1 create_init_entry based, 21 62 2 length fixed bin (35) aligned, /* size of datum */ 21 63 2 pad bit (6) unaligned, /* FUTURE EXPANSION */ 21 64 2 repeat fixed bin (30) unsigned unaligned, /* number of times to repeat datum */ 21 65 2 datum bit (0 refer (create_init_entry.length)); 21 66 21 67 21 68 /* END include file fortran_storage.incl.pl1 */ 655 22 1 /* BEGIN INCLUDE FILE ... std_descriptor_types.incl.pl1 */ 22 2 22 3 22 4 /****^ HISTORY COMMENTS: 22 5* 1) change(86-09-05,JMAthane), approve(86-09-05,MCR7525), 22 6* audit(86-09-11,Martinson), install(86-11-12,MR12.0-1208): 22 7* Added pascal_string_type_dtype descriptor type. Its number is 87. 22 8* Objects of this type are PASCAL string types. 22 9* 2) change(88-09-20,WAAnderson), approve(88-09-20,MCR7952), 22 10* audit(88-09-30,JRGray), install(88-10-24,MR12.2-1184): 22 11* Added the new C types. 22 12* END HISTORY COMMENTS */ 22 13 22 14 /* This include file defines mnemonic names for the Multics 22 15* standard descriptor types, using both pl1 and cobol terminology. 22 16* PG 780613 22 17* JRD 790530 22 18* JRD 791016 22 19* MBW 810731 22 20* TGO 830614 Add hex types. 22 21* Modified June 83 JMAthane to add PASCAL data types 22 22* TGO 840120 Add float dec extended and generic, float binary generic 22 23**/ 22 24 22 25 dcl (real_fix_bin_1_dtype init (1), 22 26 real_fix_bin_2_dtype init (2), 22 27 real_flt_bin_1_dtype init (3), 22 28 real_flt_bin_2_dtype init (4), 22 29 cplx_fix_bin_1_dtype init (5), 22 30 cplx_fix_bin_2_dtype init (6), 22 31 cplx_flt_bin_1_dtype init (7), 22 32 cplx_flt_bin_2_dtype init (8), 22 33 real_fix_dec_9bit_ls_dtype init (9), 22 34 real_flt_dec_9bit_dtype init (10), 22 35 cplx_fix_dec_9bit_ls_dtype init (11), 22 36 cplx_flt_dec_9bit_dtype init (12), 22 37 pointer_dtype init (13), 22 38 offset_dtype init (14), 22 39 label_dtype init (15), 22 40 entry_dtype init (16), 22 41 structure_dtype init (17), 22 42 area_dtype init (18), 22 43 bit_dtype init (19), 22 44 varying_bit_dtype init (20), 22 45 char_dtype init (21), 22 46 varying_char_dtype init (22), 22 47 file_dtype init (23), 22 48 real_fix_dec_9bit_ls_overp_dtype init (29), 22 49 real_fix_dec_9bit_ts_overp_dtype init (30), 22 50 real_fix_bin_1_uns_dtype init (33), 22 51 real_fix_bin_2_uns_dtype init (34), 22 52 real_fix_dec_9bit_uns_dtype init (35), 22 53 real_fix_dec_9bit_ts_dtype init (36), 22 54 real_fix_dec_4bit_uns_dtype init (38), /* digit-aligned */ 22 55 real_fix_dec_4bit_ts_dtype init (39), /* byte-aligned */ 22 56 real_fix_dec_4bit_bytealigned_uns_dtype init (40), /* COBOL */ 22 57 real_fix_dec_4bit_ls_dtype init (41), /* digit-aligned */ 22 58 real_flt_dec_4bit_dtype init (42), /* digit-aligned */ 22 59 real_fix_dec_4bit_bytealigned_ls_dtype init (43), 22 60 real_flt_dec_4bit_bytealigned_dtype init (44), 22 61 cplx_fix_dec_4bit_bytealigned_ls_dtype init (45), 22 62 cplx_flt_dec_4bit_bytealigned_dtype init (46), 22 63 real_flt_hex_1_dtype init (47), 22 64 real_flt_hex_2_dtype init (48), 22 65 cplx_flt_hex_1_dtype init (49), 22 66 cplx_flt_hex_2_dtype init (50), 22 67 c_typeref_dtype init (54), 22 68 c_enum_dtype init (55), 22 69 c_enum_const_dtype init (56), 22 70 c_union_dtype init (57), 22 71 algol68_straight_dtype init (59), 22 72 algol68_format_dtype init (60), 22 73 algol68_array_descriptor_dtype init (61), 22 74 algol68_union_dtype init (62), 22 75 22 76 cobol_comp_6_dtype init (1), 22 77 cobol_comp_7_dtype init (1), 22 78 cobol_display_ls_dtype init (9), 22 79 cobol_structure_dtype init (17), 22 80 cobol_char_string_dtype init (21), 22 81 cobol_display_ls_overp_dtype init (29), 22 82 cobol_display_ts_overp_dtype init (30), 22 83 cobol_display_uns_dtype init (35), 22 84 cobol_display_ts_dtype init (36), 22 85 cobol_comp_8_uns_dtype init (38), /* digit aligned */ 22 86 cobol_comp_5_ts_dtype init (39), /* byte aligned */ 22 87 cobol_comp_5_uns_dtype init (40), 22 88 cobol_comp_8_ls_dtype init (41), /* digit aligned */ 22 89 real_flt_dec_extended_dtype init (81), /* 9-bit exponent */ 22 90 cplx_flt_dec_extended_dtype init (82), /* 9-bit exponent */ 22 91 real_flt_dec_generic_dtype init (83), /* generic float decimal */ 22 92 cplx_flt_dec_generic_dtype init (84), 22 93 real_flt_bin_generic_dtype init (85), /* generic float binary */ 22 94 cplx_flt_bin_generic_dtype init (86)) fixed bin internal static options (constant); 22 95 22 96 dcl (ft_integer_dtype init (1), 22 97 ft_real_dtype init (3), 22 98 ft_double_dtype init (4), 22 99 ft_complex_dtype init (7), 22 100 ft_complex_double_dtype init (8), 22 101 ft_external_dtype init (16), 22 102 ft_logical_dtype init (19), 22 103 ft_char_dtype init (21), 22 104 ft_hex_real_dtype init (47), 22 105 ft_hex_double_dtype init (48), 22 106 ft_hex_complex_dtype init (49), 22 107 ft_hex_complex_double_dtype init (50) 22 108 ) fixed bin internal static options (constant); 22 109 22 110 dcl (algol68_short_int_dtype init (1), 22 111 algol68_int_dtype init (1), 22 112 algol68_long_int_dtype init (2), 22 113 algol68_real_dtype init (3), 22 114 algol68_long_real_dtype init (4), 22 115 algol68_compl_dtype init (7), 22 116 algol68_long_compl_dtype init (8), 22 117 algol68_bits_dtype init (19), 22 118 algol68_bool_dtype init (19), 22 119 algol68_char_dtype init (21), 22 120 algol68_byte_dtype init (21), 22 121 algol68_struct_struct_char_dtype init (22), 22 122 algol68_struct_struct_bool_dtype init (20) 22 123 ) fixed bin internal static options (constant); 22 124 22 125 dcl (label_constant_runtime_dtype init (24), 22 126 int_entry_runtime_dtype init (25), 22 127 ext_entry_runtime_dtype init (26), 22 128 ext_procedure_runtime_dtype init (27), 22 129 picture_runtime_dtype init (63) 22 130 ) fixed bin internal static options (constant); 22 131 22 132 dcl (pascal_integer_dtype init (1), 22 133 pascal_real_dtype init (4), 22 134 pascal_label_dtype init (24), 22 135 pascal_internal_procedure_dtype init (25), 22 136 pascal_exportable_procedure_dtype init (26), 22 137 pascal_imported_procedure_dtype init (27), 22 138 pascal_typed_pointer_type_dtype init (64), 22 139 pascal_char_dtype init (65), 22 140 pascal_boolean_dtype init (66), 22 141 pascal_record_file_type_dtype init (67), 22 142 pascal_record_type_dtype init (68), 22 143 pascal_set_dtype init (69), 22 144 pascal_enumerated_type_dtype init (70), 22 145 pascal_enumerated_type_element_dtype init (71), 22 146 pascal_enumerated_type_instance_dtype init (72), 22 147 pascal_user_defined_type_dtype init (73), 22 148 pascal_user_defined_type_instance_dtype init (74), 22 149 pascal_text_file_dtype init (75), 22 150 pascal_procedure_type_dtype init (76), 22 151 pascal_variable_formal_parameter_dtype init (77), 22 152 pascal_value_formal_parameter_dtype init (78), 22 153 pascal_entry_formal_parameter_dtype init (79), 22 154 pascal_parameter_procedure_dtype init (80), 22 155 pascal_string_type_dtype init (87)) fixed bin int static options (constant); 22 156 22 157 22 158 /* END INCLUDE FILE ... std_descriptor_types.incl.pl1 */ 656 657 658 /* initialize */ 659 660 cur_statement = -1; /* Until a st node exists, there is no st text for errors */ 661 allocate_symbol_name = 0; /* no names for symbols created by code generator */ 662 unspec (def_pool) = "0"b; 663 first_frame = null; 664 next_free_ms = null; 665 auto_template = 0; 666 unspec (builtins) = "0"b; 667 text_pos, link_pos, def_pos, sym_pos, lib_pos, profile_start = 0; 668 first_namelist, last_namelist = 0; 669 free_temps (1), free_temps (2), free_temps (3) = 0; 670 segname = vsegname; 671 672 free (*) = shared_globals.free (*); 673 freei = shared_globals.freei; 674 675 assembly_list = shared_globals.options.list; 676 if assembly_list 677 then a_base = addr (source_list (number_of_lines + 2)); 678 else a_base = null; 679 680 /* allocate all constants passed as arg */ 681 682 call alloc_constants (first_dw_constant, 2); 683 call alloc_constants (first_word_constant, 1); 684 call alloc_char_constants (first_char_constant); 685 686 /* allocate storage */ 687 688 begin_external_list = next_free_polish; 689 690 call assign_storage; 691 692 /* set up for interpreting */ 693 694 end_external_list = next_free_polish; 695 696 /* Perform Register Usage Analysis and Global Register Allocation by 697* running a special pass of the interpreter. */ 698 699 call save_before_analysis; 700 701 call interpreter ("1"b); 702 703 call restore_after_analysis; 704 705 if error_level >= unrecoverable_error 706 then return; 707 708 begin_forward_refs = next_free_polish; 709 710 /* interpret for code generation */ 711 712 call interpreter ("0"b); 713 714 last_pos = text_pos; 715 716 /* allocate all constants that need storage */ 717 718 text_pos = text_pos + mod (text_pos, 2); 719 720 call alloc_char_constants (first_block_constant); 721 call alloc_constants (first_dw_constant, 2); 722 call alloc_constants (first_word_constant, 1); 723 call alloc_char_constants (first_char_constant); 724 725 /* resolve all forward references */ 726 727 do i = begin_forward_refs to hbound (forward_refs, 1); 728 j = forward_refs (i).instruction; 729 text_halfs (j).left = text_halfs (j).left + addr (rands (forward_refs (i).operand)) -> label.location; 730 end; 731 732 /* free up space so name_assign can use */ 733 734 next_free_polish = begin_forward_refs; 735 736 /* allocate library structure */ 737 738 if first_lib_name ^= 0 739 then do; 740 lib_pos = text_pos; 741 lib_list_ptr = addrel (object_base, lib_pos); 742 lib_reloc_ptr = addrel (relocation_base, lib_pos); 743 n = num_of_lib_names; 744 saved_lib_list.nlibs = n; 745 text_pos = text_pos + size (saved_lib_list); 746 747 i = 1; 748 do lib = first_lib_name repeat lib_pt -> library.next_library_node while (lib > 0); 749 lib_pt = addr (rands (lib)); 750 c = addr (rands (lib_pt -> library.character_operand)); 751 saved_lib_list.offset (i) = unspec (c -> char_constant.location); 752 saved_lib_list.lng (i) = c -> char_constant.length; 753 saved_lib_reloc_list.reloc (i) = rc_t; 754 i = i + 1; 755 end; 756 end; 757 758 /* initialize static */ 759 760 linkrel = divide (text_pos + 1, 2, 17, 0) * 2; 761 link_base = addrel (object_base, linkrel); 762 link_reloc_base = addrel (relocation_base, linkrel); 763 764 call initialize_static; 765 766 /* generate links */ 767 768 defrel = link_pos + linkrel; 769 def_base = addrel (object_base, defrel); 770 def_reloc_base = addrel (relocation_base, defrel); 771 772 call init_linkage; 773 call gen_linkage; 774 775 /* generate entry definitions */ 776 777 call gen_entry_defs; 778 779 /* generate library definition */ 780 781 if lib_pos ^= 0 782 then call generate_definition ("library_list_", 0, bit (lib_pos, 18)); 783 784 /* free up space for make symbol_table that is no longer used */ 785 786 next_free_polish = begin_forward_refs; 787 788 /* generate symbol section */ 789 790 symrel = divide (defrel + def_pos + 1, 2, 17, 0) * 2; 791 792 symtab_parameters.link_base_ptr = link_base; 793 symtab_parameters.link_reloc_base_ptr = link_reloc_base; 794 symtab_parameters.def_reloc_base_ptr = def_reloc_base; 795 symtab_parameters.current_text_offset = text_pos; 796 symtab_parameters.current_def_offset = def_pos; 797 symtab_parameters.current_link_offset = link_pos; 798 symtab_parameters.final_text_offset = last_pos; 799 symtab_parameters.profile_offset = profile_start; 800 symtab_parameters.star_symbol_link = builtins (9); 801 symtab_parameters.first_namelist_symbol = first_namelist; 802 803 call fort_make_symbol_section (shared_struc_ptr, cg_struc_ptr, addr (symtab_parameters), symrel, sym_pos); 804 805 /* finish up the object segment by filling in the 806* standard object map */ 807 808 n = divide (symrel + sym_pos + 1, 2, 17, 0) * 2; 809 p = addrel (object_base, n); 810 811 p -> object_map.decl_vers = object_map_version_2; 812 p -> object_map.identifier = "obj_map"; 813 p -> object_map.text_length = bit (text_pos, 18); 814 p -> object_map.definition_offset = bit (defrel, 18); 815 p -> object_map.definition_length = bit (def_pos, 18); 816 p -> object_map.linkage_offset = bit (linkrel, 18); 817 p -> object_map.linkage_length = bit (link_pos, 18); 818 p -> object_map.static_offset = bit (fixed (linkrel + size (virgin_linkage_header), 18), 18); 819 p -> object_map.static_length = bit (fixed (begin_links - size (virgin_linkage_header), 18), 18); 820 p -> object_map.symbol_offset = bit (symrel, 18); 821 p -> object_map.symbol_length = bit (sym_pos, 18); 822 823 p -> object_map.format.separate_static = "0"b; 824 825 p -> object_map.format.relocatable = shared_globals.options.relocatable; 826 827 p -> object_map.format.procedure, p -> object_map.format.standard = "1"b; 828 829 addrel (p, size (p -> object_map)) -> map_ptr = bit (n, 18); 830 831 /* set next_free_object and return */ 832 833 next_free_object = n + size (p -> object_map) + 1; 834 return; 835 836 get_subr_options: 837 procedure (cs); 838 839 /* Sets various global flags to correspond to the options in 840* effect for the given program unit. */ 841 842 dcl cs pointer; /* Pointer to subprogram node */ 843 844 do_rounding = cs -> subprogram.options.do_rounding; 845 init_auto_to_zero = cs -> subprogram.options.auto_zero; 846 generate_profile = cs -> subprogram.options.profile; 847 generate_long_profile = cs -> subprogram.options.long_profile; 848 generate_symtab = cs -> subprogram.options.table | shared_globals.options.namelist_used; 849 850 return; 851 852 end get_subr_options; 853 854 /**** CONSTANT ALLOCATION ****/ 855 856 alloc_constants: 857 procedure (start, amt); 858 859 /* Allocates constants in the text section */ 860 861 dcl (amt, n) fixed binary; 862 dcl start fixed binary (18); 863 864 n = amt; 865 866 do con = start repeat c -> constant.next_constant while (con > 0); 867 c = addr (rands (con)); 868 if ^c -> constant.allocated 869 then if c -> constant.allocate | c -> constant.passed_as_arg 870 then do; 871 c -> constant.location = text_pos; 872 addrel (object_base, text_pos) -> image = addr (c -> constant.value) -> image; 873 text_pos = text_pos + n; 874 c -> constant.allocated = "1"b; 875 end; 876 end; 877 878 end alloc_constants; 879 880 alloc_char_constants: 881 procedure (start); 882 883 /* Allocates character constants in the text section */ 884 885 dcl start fixed binary (18); 886 dcl relocate_itp bit (1) aligned; 887 888 relocate_itp = start = first_block_constant; 889 890 do con = start repeat c -> char_constant.next_constant while (con > 0); 891 c = addr (rands (con)); 892 if ^c -> char_constant.allocated 893 then if c -> char_constant.allocate | c -> char_constant.passed_as_arg 894 then do; 895 if c -> char_constant.length = chars_per_dw 896 /* a double word constant */ 897 then text_pos = text_pos + mod (text_pos, 2); 898 /* get even address */ 899 900 amt = divide (c -> char_constant.length + chars_per_word - 1, chars_per_word, 17, 0); 901 c -> char_constant.location = text_pos; 902 addrel (object_base, text_pos) -> char_image = c -> char_constant.value; 903 if relocate_itp 904 then call relocate_itp_list; 905 text_pos = text_pos + amt; 906 c -> char_constant.allocated = "1"b; 907 end; 908 end; 909 910 end alloc_char_constants; 911 912 relocate_itp_list: 913 procedure (); 914 915 /* Generates relocation bits for an itp argument list */ 916 917 dcl q pointer; 918 dcl rscan fixed binary (18); 919 920 do rscan = text_pos + 2 to text_pos + amt - 1 by 2; 921 q = addrel (object_base, rscan); 922 923 if q -> itp.itp_mod = ITP_mod /* ITP word */ 924 then if q -> itp.pr_no = lp 925 then reloc_halfs (rscan + 1).left = rc_is18; 926 else ; 927 else if q -> itp.itp_mod = "00"b3 /* ordinary indirect word */ 928 then reloc_halfs (rscan).left = rc_t; 929 end; 930 931 end relocate_itp_list; 932 933 assign_address_offset: 934 procedure (p, inc, size, units); 935 936 /* This procedure sets node.address.offset and node.location 937* from node.location and the offset increment inc. */ 938 939 dcl p pointer; /* Node pointer */ 940 dcl inc fixed binary (18); /* Offset increment */ 941 dcl size fixed binary (18); /* Size of datum */ 942 dcl units fixed binary (3); /* Units of size */ 943 944 call set_address_offset ((p), (p -> node.location + inc), (size), (units)); 945 946 end assign_address_offset; 947 948 set_address_offset: 949 procedure (p, off, size, units); 950 951 /* Sets p -> node.address.offset and p -> node.location to 952* the correct values for the offset off. */ 953 954 dcl p pointer; 955 dcl (off, loc, offset) fixed binary (18); 956 dcl size fixed binary (18); 957 dcl units fixed binary (3); 958 959 offset = off; 960 961 if abs (offset) + get_size_in_words ((size), (units)) - 1 >= 16384 962 then do; 963 loc = offset; 964 p -> node.large_address = "1"b; 965 p -> node.is_addressable = "0"b; 966 offset = mod (offset + 16384, 32768) - 16384; 967 p -> node.location = loc - offset; 968 end; 969 970 p -> node.address.offset = offset; 971 972 end set_address_offset; 973 974 get_size_in_words: 975 procedure (size, units) returns (fixed binary (18)); 976 977 /* Converts a size in the specified units to word units */ 978 979 dcl size fixed binary (18); 980 dcl (units, u) fixed binary (3); 981 982 dcl factor (0:3) fixed binary (18) internal static options (constant) initial (1, 36, 4, 2); 983 984 u = mod (units, 4); 985 986 if u = word_units 987 then return (size); /* For speed */ 988 989 return (divide (size + factor (u) - 1, factor (u), 18, 0)); 990 991 end get_size_in_words; 992 993 get_size_in_bits: 994 procedure (size, units) returns (fixed binary (18)); 995 996 /* Converts a size in the specified units to bits */ 997 998 dcl size fixed binary (18); 999 dcl (units, u) fixed binary (3); 1000 1001 dcl factor (0:3) fixed binary (18) internal static options (constant) initial (36, 1, 9, 18); 1002 1003 u = mod (units, 4); 1004 return (size * factor (u)); 1005 1006 end get_size_in_bits; 1007 1008 save_before_analysis: 1009 procedure (); 1010 1011 /* Saves vars neded for code generation. */ 1012 1013 hold_last_auto_loc = last_auto_loc; 1014 hold_text_pos = text_pos; 1015 1016 end save_before_analysis; 1017 1018 restore_after_analysis: 1019 procedure (); 1020 1021 dcl (cs, s) pointer; 1022 dcl sym fixed binary (18); 1023 1024 /* Restores labels and entry points */ 1025 1026 do sym = first_entry_name repeat s -> symbol.next_symbol while (sym > 0); 1027 s = addr (rands (sym)); 1028 s -> symbol.allocated = "0"b; 1029 if s -> symbol.initial ^= 0 1030 then addr (rands (s -> symbol.initial)) -> label.allocated = "0"b; 1031 end; 1032 1033 do cur_subprogram = first_subprogram repeat cs -> subprogram.next_subprogram while (cur_subprogram > 0); 1034 cs = addr (rands (cur_subprogram)); 1035 do sym = cs -> subprogram.first_label repeat s -> label.next_label while (sym > 0); 1036 s = addr (rands (sym)); 1037 s -> label.allocated = "0"b; 1038 end; 1039 end; 1040 1041 /* Restore saved values. */ 1042 1043 if generate_long_profile 1044 then profile_pos = size (long_profile_header); 1045 else profile_pos = profile_start; 1046 text_pos = hold_text_pos; 1047 last_auto_loc = hold_last_auto_loc; 1048 1049 end restore_after_analysis; 1050 1051 assign_storage: 1052 procedure (); 1053 1054 /* STORAGE ALLOCATOR 1055* 1056* subprogram.storage_info is organized into 17 buckets to aid in 1057* storage allocation. The buckets are assigned as follows: 1058* 1059* 1 auto double init 1060* 2 auto single init 1061* 3 auto double 1062* 4 auto single 1063* 5 static double init 1064* 6 static single init 1065* 7 static double 1066* 8 static single 1067* 9 common & external constants 1068* 10 parameters 1069* 11 others 1070* 12 not allocated 1071* 13 Large Array Automatic 1072* 14 Large Array Static 1073* 15 Very Large Array Automatic 1074* 16 Very Large Array Static 1075* 17 Very Large Array Common 1076* */ 1077 1078 dcl (cs, h, os, clp, psp, psap, s, ssp) pointer; 1079 dcl (hdr, sym, i, vsize, other_sym) fixed binary (18); 1080 dcl loc fixed binary (18); 1081 dcl not_found bit (1) aligned; 1082 dcl alloc_ps bit (1) aligned; 1083 23 1 /* BEGIN INCLUDE FILE relocation_bits.incl.pl1 */ 23 2 23 3 /* This include file defines the relocation bits as bit (6) entities. See 23 4* also relbts.incl.pl1 and reloc_lower.incl.pl1. */ 23 5 23 6 dcl ( rc_a initial("000000"b), /* absolute */ 23 7 rc_t initial("010000"b), /* text */ 23 8 rc_nt initial("010001"b), /* negative text */ 23 9 rc_lp18 initial("010010"b), /* linkage, 18 bit */ 23 10 rc_nlp18 initial("010011"b), /* negative link, 18 bit */ 23 11 rc_lp15 initial("010100"b), /* linkage, 15 bit */ 23 12 rc_dp initial("010101"b), /* def section */ 23 13 rc_s initial("010110"b), /* symbol segment */ 23 14 rc_ns initial("010111"b), /* negative symbol */ 23 15 rc_is18 initial("011000"b), /* internal static 18 */ 23 16 rc_is15 initial("011001"b), /* internal static 15 */ 23 17 rc_lb initial("011000"b), /* link block */ 23 18 rc_nlb initial("011001"b), /* negative link block */ 23 19 rc_sr initial("011010"b), /* self relative */ 23 20 rc_e initial("011111"b)) /* escape */ 23 21 bit(6) int static options(constant); 23 22 23 23 /* END INCLUDE FILE relocation_bits.incl.pl1 */ 1084 1085 1086 /* 78.06.12 The parse now sets the following fields formerly set by the storage allocator. 1087* Note that these fields are only set for those variables that need them: 1088* 1089* symbol.data_type 1090* symbol.element_size 1091* symbol.auto } One of these is set but only if the symbol 1092* symbol.static } is a variable without a storage class 1093* */ 1094 1095 last_auto_loc = first_auto_loc; 1096 1097 /* link_pos is the current offset of linkage entries from the end of static 1098* for the duration of external assignement. Then it transforms to be the 1099* current address in the linkage section of relocation of static. 1100* linkage_pad is the space which is occupied by the 1101* LA and VLA base pointers for static variables. linkage_pad delineates a 1102* section which is within static, but which is not filled with normal variables. */ 1103 1104 linkage_pad = 0; 1105 1106 Area_create_first, Area_init_first = -1; /* flag off */ 1107 1108 alloc_ps, alloc_auto_cleanup = "0"b; 1109 1110 /* setup for cleanup of VLA common processing lists */ 1111 1112 on cleanup call cleanup_VLA_common; 1113 1114 /* allocate entry points */ 1115 1116 do sym = first_entry_name repeat s -> symbol.next_symbol while (sym > 0); 1117 s = addr (rands (sym)); 1118 1119 s -> symbol.operand_type = entry_type; 1120 s -> symbol.hash_chain = 0; 1121 s -> symbol.is_addressable = "1"b; 1122 s -> symbol.reloc = rc_t; 1123 1124 /* associate a quick entry point with a subprogram entry pt */ 1125 1126 if s -> symbol.name ^= main_entry_point_name 1127 then s -> symbol.initial = create_rel_constant (null); 1128 end; 1129 1130 /* do allocation for each subprogram */ 1131 1132 do cur_subprogram = first_subprogram repeat cs -> subprogram.next_subprogram while (cur_subprogram > 0); 1133 cs = addr (rands (cur_subprogram)); 1134 call get_subr_options (cs); 1135 1136 /* see if ps needed */ 1137 1138 alloc_ps = alloc_ps | cs -> subprogram.need_PS; 1139 1140 /* allocate labels */ 1141 1142 do sym = cs -> subprogram.first_label repeat s -> label.next_label while (sym > 0); 1143 s = addr (rands (sym)); 1144 s -> label.is_addressable = "1"b; 1145 s -> label.reloc = rc_t; 1146 end; 1147 1148 /* initialize storage info */ 1149 1150 unspec (cs -> subprogram.storage_info) = "0"b; 1151 1152 /* Allocate vars in LA chain */ 1153 1154 hdr = cs -> subprogram.LA_chain; 1155 do while (hdr > 0); 1156 h = addr (rands (hdr)); 1157 if h -> header.allocate 1158 then do; 1159 h -> header.needs_pointer = "1"b; 1160 unspec (h -> header.address) = ext_base_on; 1161 h -> header.allocated = "1"b; 1162 1163 call alloc_members; 1164 1165 h -> header.reloc = RI_mod; 1166 1167 /* Allocate the unpacked pointer storage in either static or automatic */ 1168 1169 if h -> header.static 1170 then do; 1171 i = 14; /* LA static */ 1172 if mod (linkage_pad + size (virgin_linkage_header), 2) ^= 0 1173 then linkage_pad = linkage_pad + 1; 1174 h -> header.location = linkage_pad + size (virgin_linkage_header); 1175 h -> header.base = lp; 1176 linkage_pad = linkage_pad + 2;/* assign double word */ 1177 end; 1178 else do; 1179 i = 13; /* LA auto */ 1180 if mod (last_auto_loc, 2) ^= 0 1181 then last_auto_loc = last_auto_loc + 1; 1182 /* even word aligned */ 1183 1184 h -> header.location = last_auto_loc; 1185 h -> header.base = sp; 1186 last_auto_loc = last_auto_loc + 2; 1187 end; 1188 1189 1190 call create_storage_entry (h); 1191 1192 /* relocate members of Large Arrays */ 1193 1194 do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 1195 s = addr (rands (sym)); 1196 call assign_address_offset (s, 0, (s -> symbol.element_size), (s -> symbol.units)); 1197 end; 1198 1199 if h -> header.initialed 1200 then call list_initialize (addrel (object_base, text_pos), hdr, text_pos); 1201 1202 /* thread the block on the LA lists */ 1203 1204 if cs -> subprogram.storage_info.last (i) = 0 1205 then cs -> subprogram.storage_info.first (i) = hdr; 1206 else addr (rands (cs -> subprogram.storage_info.last (i))) -> header.next_header = hdr; 1207 cs -> subprogram.storage_info.last (i) = hdr; 1208 1209 end; 1210 1211 /* on to the next header */ 1212 1213 hdr = h -> header.next_header; 1214 h -> header.next_header = 0; 1215 end; 1216 1217 /* Allocate vars in VLA chain */ 1218 1219 hdr = cs -> subprogram.VLA_chain; 1220 do while (hdr > 0); 1221 h = addr (rands (hdr)); 1222 if h -> header.allocate 1223 then do; 1224 h -> header.allocated = "1"b; 1225 h -> header.needs_pointer = "1"b; 1226 unspec (h -> header.address) = ext_base_on; 1227 if h -> header.automatic 1228 then h -> header.address.base = sp; 1229 else do; 1230 h -> header.address.base = lp; 1231 h -> header.reloc = rc_is15; 1232 end; 1233 1234 call alloc_members; 1235 1236 /* Allocate the base addressor. */ 1237 1238 s = addr (rands (h -> header.VLA_base_addressor)); 1239 s -> symbol.is_addressable = "1"b; 1240 s -> symbol.allocated = "1"b; 1241 s -> symbol.address = h -> header.address; 1242 s -> symbol.reloc = h -> header.reloc; 1243 1244 if h -> header.in_common 1245 then do; 1246 i = 17; /* VLA common */ 1247 call note_VLA_common (h); 1248 end; 1249 else do; 1250 1251 /* Allocate the addressor storage in either static or automatic */ 1252 1253 if h -> header.static 1254 then do; 1255 i = 16; /* VLA static */ 1256 h -> header.location, h -> header.address.offset = 1257 linkage_pad + size (virgin_linkage_header); 1258 linkage_pad = linkage_pad + 1; 1259 /* space for base addressor */ 1260 end; 1261 else do; 1262 i = 15; /* VLA auto */ 1263 1264 h -> header.location, h -> header.address.offset = last_auto_loc; 1265 last_auto_loc = last_auto_loc + 1; 1266 /* space for base addressor */ 1267 end; 1268 call set_address_offset (s, (h -> header.location), 1, word_units); 1269 call create_storage_entry (h); 1270 if h -> header.initialed 1271 then call list_initialize (addrel (object_base, text_pos), hdr, text_pos); 1272 end; 1273 1274 /* thread the block on the VLA lists */ 1275 1276 if cs -> subprogram.storage_info.last (i) = 0 1277 then cs -> subprogram.storage_info.first (i) = hdr; 1278 else addr (rands (cs -> subprogram.storage_info.last (i))) -> header.next_header = hdr; 1279 cs -> subprogram.storage_info.last (i) = hdr; 1280 1281 end; 1282 1283 /* on to the next header */ 1284 1285 hdr = h -> header.next_header; 1286 h -> header.next_header = 0; 1287 end; 1288 1289 /* Allocate vars in common chain */ 1290 1291 hdr = cs -> subprogram.common_chain; 1292 do while (hdr > 0); 1293 h = addr (rands (hdr)); 1294 if h -> header.allocate 1295 then do; 1296 h -> header.needs_pointer = "1"b; 1297 unspec (h -> header.address) = ext_base_on; 1298 h -> header.allocated = "1"b; 1299 1300 call alloc_members; 1301 1302 h -> header.location = alloc_external (h); 1303 1304 /* thread the block on the linkage list */ 1305 1306 if cs -> subprogram.storage_info.last (9) = 0 1307 then cs -> subprogram.storage_info.first (9) = hdr; 1308 else addr (rands (cs -> subprogram.storage_info.last (9))) -> header.next_header = hdr; 1309 cs -> subprogram.storage_info.last (9) = hdr; 1310 1311 end; 1312 1313 /* on to the next header */ 1314 1315 hdr = h -> header.next_header; 1316 h -> header.next_header = 0; 1317 end; 1318 1319 /* Allocate other equivalence blocks */ 1320 1321 hdr = cs -> subprogram.equiv_chain; 1322 do while (hdr > 0); 1323 h = addr (rands (hdr)); 1324 if h -> header.allocate 1325 then do; 1326 1327 /* get subclass of equivalence group */ 1328 1329 if h -> header.even 1330 then i = 1; 1331 else i = 2; 1332 if ^h -> header.initialed 1333 then i = i + 2; 1334 if h -> header.static 1335 then i = i + 4; 1336 1337 /* allocate */ 1338 1339 if h -> header.odd 1340 then if mod (cs -> subprogram.next_loc (i), 2) = 0 1341 then cs -> subprogram.next_loc (i) = cs -> subprogram.next_loc (i) + 1; 1342 1343 loc = cs -> subprogram.next_loc (i); 1344 cs -> subprogram.next_loc (i) = cs -> subprogram.next_loc (i) + h -> header.length; 1345 if mod (i, 2) ^= 0 1346 then cs -> subprogram.next_loc (i) = cs -> subprogram.next_loc (i) + mod (h -> header.length, 2); 1347 1348 1349 unspec (h -> header.address) = ext_base_on; 1350 h -> header.location = loc; 1351 if h -> header.static 1352 then do; 1353 h -> header.base = lp; 1354 h -> header.reloc = rc_is15; 1355 end; 1356 else h -> header.base = sp; 1357 h -> header.is_addressable = "1"b; 1358 h -> header.allocated = "1"b; 1359 1360 /* allocate elements of equiv chain */ 1361 1362 call alloc_members; 1363 end; 1364 1365 else i = 12; 1366 1367 /* thread the header in */ 1368 1369 if cs -> subprogram.storage_info.last (i) = 0 1370 then cs -> subprogram.storage_info.first (i) = hdr; 1371 else addr (rands (cs -> subprogram.storage_info.last (i))) -> header.next_header = hdr; 1372 cs -> subprogram.storage_info.last (i) = hdr; 1373 1374 hdr = h -> header.next_header; 1375 h -> header.next_header = 0; 1376 end; 1377 1378 /* Allocate non-equivalenced symbols */ 1379 1380 sym = cs -> subprogram.first_symbol; 1381 do while (sym > 0); 1382 s = addr (rands (sym)); 1383 if ^s -> symbol.allocated 1384 then do; 1385 if s -> symbol.parameter 1386 then s -> symbol.hash_chain = 0; /* Required by 'make_symbol_descriptor'. */ 1387 1388 /* Fix up request for 'PARAMETER' variables fully probe-able by allocating if 1389* we want a symbol table. */ 1390 1391 if s -> symbol.named_constant & cs -> subprogram.options.table 1392 then do; 1393 s -> symbol.allocate = "1"b; 1394 addr (rands (s -> symbol.initial)) -> node.allocate = "1"b; 1395 end; 1396 1397 if s -> symbol.allocate 1398 then do; 1399 unspec (s -> symbol.address) = "0"b; 1400 1401 s -> symbol.hash_chain = 0; 1402 1403 if s -> symbol.stmnt_func 1404 then do; 1405 s -> symbol.operand_type = statement_function; 1406 i = 11; 1407 end; 1408 else if s -> symbol.builtin 1409 then do; 1410 s -> symbol.operand_type = bif; 1411 i = 11; 1412 end; 1413 else if s -> symbol.named_constant 1414 then i = 11; 1415 else if s -> symbol.namelist 1416 then do; 1417 s -> label.location = text_pos; 1418 s -> symbol.is_addressable = "1"b; 1419 s -> symbol.reloc = rc_t; 1420 1421 vsize = divide (polish (s -> symbol.initial) + 4, 2, 17, 0); 1422 text_pos = text_pos + vsize; 1423 1424 if last_namelist = 0 1425 then first_namelist = sym; 1426 else addr (rands (last_namelist)) -> symbol.next_member = sym; 1427 last_namelist = sym; 1428 1429 i = 11; 1430 end; 1431 else if s -> symbol.parameter | s -> symbol.stack_indirect 1432 then do; 1433 i = 10; 1434 if s -> symbol.external 1435 then s -> symbol.operand_type = external; 1436 else s -> symbol.operand_type = variable_type; 1437 1438 if s -> symbol.VLA 1439 then do; 1440 1441 /* Allocate the base addressor of the VLA. */ 1442 other_sym = addr (rands (s -> symbol.dimension)) -> dimension.VLA_base_addressor; 1443 os = addr (rands (other_sym)); 1444 os -> symbol.is_addressable = "1"b; 1445 os -> symbol.allocated = "1"b; 1446 unspec (os -> symbol.address) = ext_base_on; 1447 os -> symbol.address.base = sp; 1448 os -> symbol.address.offset = last_auto_loc; 1449 if ^VLA_is_256K 1450 then last_auto_loc = last_auto_loc + 1; 1451 1452 /* Allocate the packed ptr to the VLA. */ 1453 if last_auto_loc > max_address_offset 1454 then call print_message (414, "The location of a VLA parameter base pointer", 1455 max_address_offset - bias); 1456 s -> symbol.needs_pointer = "1"b; 1457 s -> symbol.address.base = sp; 1458 s -> symbol.address.offset = last_auto_loc; 1459 last_auto_loc = last_auto_loc + 1; 1460 s -> symbol.location = s -> symbol.location * 2; 1461 end; 1462 1463 else if s -> symbol.stack_indirect 1464 then do; 1465 1466 /* multiple positions -- we need an auto 1467* ptr to point at the parameter */ 1468 1469 if mod (last_auto_loc, 2) ^= 0 1470 then last_auto_loc = last_auto_loc + 1; 1471 /* even word aligned */ 1472 s -> symbol.location = last_auto_loc; 1473 last_auto_loc = last_auto_loc + 2; 1474 if last_auto_loc > max_stack_size 1475 then call print_message (414, 1476 "in making multiple position parameter temporary the stack frame", 1477 max_stack_size - bias); 1478 end; 1479 1480 else /* the actual ptr location is twice the parameter number */ 1481 s -> symbol.location = s -> symbol.location * 2; 1482 1483 /* set up address field */ 1484 1485 s -> symbol.ext_base = "1"b; 1486 1487 if s -> symbol.dimensioned 1488 then do; 1489 s -> symbol.needs_pointer = "1"b; 1490 vsize = get_array_size (s); 1491 end; 1492 else if s -> symbol.data_type = cmpx_mode 1493 then s -> symbol.needs_pointer = "1"b; 1494 else if s -> symbol.data_type = char_mode 1495 then do; 1496 s -> symbol.needs_pointer = "1"b; 1497 if s -> symbol.variable_extents | s -> symbol.star_extents 1498 then if s -> symbol.needs_descriptors | s -> symbol.passed_as_arg 1499 | s -> symbol.put_in_symtab | shared_globals.options.table 1500 then vsize = make_symbol_descriptor (fixed (rel (s), 18)); 1501 end; 1502 else do; 1503 if ^s -> symbol.VLA 1504 then do; 1505 s -> symbol.address.offset = s -> symbol.location; 1506 s -> symbol.tag = RI_mod; 1507 /* RI */ 1508 end; 1509 else s -> symbol.tag = rc_a; 1510 /* stack */ 1511 if s -> symbol.stack_indirect 1512 then do; 1513 s -> symbol.address.base = sp; 1514 s -> symbol.is_addressable = "1"b; 1515 end; 1516 end; 1517 end; 1518 else if s -> symbol.external 1519 then do; 1520 1521 /* function or subroutine reference */ 1522 1523 s -> symbol.operand_type = external; 1524 1525 /* check if name is on subprogram in this compilation */ 1526 1527 not_found = "1"b; 1528 other_sym = first_entry_name; 1529 do while (other_sym > 0 & not_found); 1530 os = addr (rands (other_sym)); 1531 if s -> symbol.name = os -> symbol.name 1532 then not_found = "0"b; 1533 else other_sym = os -> symbol.next_symbol; 1534 end; 1535 1536 if not_found 1537 then do; 1538 s -> symbol.ext_base = "1"b; 1539 s -> symbol.base = lp; 1540 s -> symbol.location = alloc_external (s); 1541 s -> symbol.tag = RI_mod; 1542 /* RI */ 1543 s -> symbol.reloc = rc_lp15; 1544 s -> symbol.is_addressable = "1"b; 1545 end; 1546 1547 else do; 1548 s -> symbol.is_addressable = "0"b; 1549 s -> symbol.reloc = rc_t; 1550 s -> symbol.initial = other_sym; 1551 s -> symbol.needs_descriptors = os -> symbol.needs_descriptors; 1552 end; 1553 1554 i = 9; 1555 end; 1556 else do; 1557 1558 /* data type and storage class (must be auto or static) assigned by the parse */ 1559 1560 s -> symbol.operand_type = variable_type; 1561 1562 if s -> symbol.dimensioned 1563 then vsize = get_array_size (s); 1564 else vsize = get_size_in_words ((s -> symbol.element_size), (s -> symbol.units)); 1565 1566 /* get subclass */ 1567 1568 if data_type_size (s -> symbol.data_type) = 2 1569 then i = 1; 1570 else i = 2; 1571 if ^s -> symbol.initialed 1572 then i = i + 2; 1573 if s -> symbol.static 1574 then i = i + 4; 1575 1576 /* allocate */ 1577 1578 loc = cs -> subprogram.next_loc (i); 1579 cs -> subprogram.next_loc (i) = cs -> subprogram.next_loc (i) + vsize; 1580 1581 /* set up addressing */ 1582 1583 if s -> symbol.static 1584 then do; 1585 s -> symbol.base = lp; 1586 s -> symbol.reloc = rc_is15; 1587 end; 1588 else s -> symbol.base = sp; 1589 s -> symbol.location = loc; 1590 s -> symbol.ext_base = "1"b; 1591 1592 s -> symbol.is_addressable = "1"b; 1593 end; 1594 1595 /* set allocated bit */ 1596 1597 s -> symbol.allocated = "1"b; 1598 end; 1599 1600 else i = 12; 1601 1602 /* thread symbol into new list */ 1603 1604 if cs -> subprogram.storage_info.last (i) = 0 1605 then cs -> subprogram.storage_info.first (i) = sym; 1606 else addr (rands (cs -> subprogram.storage_info.last (i))) -> symbol.next_symbol = sym; 1607 cs -> subprogram.storage_info.last (i) = sym; 1608 end; 1609 1610 sym = s -> symbol.next_symbol; 1611 s -> symbol.next_symbol = 0; 1612 end; 1613 1614 end; 1615 1616 /* Allocate <*symbol>|0 link, if necessary */ 1617 1618 if generate_symtab 1619 then do; 1620 1621 /* compile_link depends on symbol.name_length being 0 */ 1622 1623 builtins (9) = create_node (symbol_node, size (symbol)); 1624 ssp = addr (rands (builtins (9))); 1625 ssp -> symbol.operand_type = dummy; 1626 ssp -> symbol.by_compiler = "1"b; 1627 ssp -> symbol.external, ssp -> symbol.allocate, ssp -> symbol.allocated, ssp -> symbol.is_addressable, 1628 ssp -> symbol.ext_base = "1"b; 1629 ssp -> symbol.base = lp; 1630 ssp -> symbol.tag = RI_mod; /* RI */ 1631 ssp -> symbol.reloc = rc_lp15; 1632 ssp -> symbol.location = alloc_external (ssp); 1633 end; 1634 else builtins (9) = 0; 1635 1636 /* If a ps is needed, allocate it first to prevent problems with 16K boundary. 1637* ps must be in automatic storage because namelist, err=, and end= require current stack 1638* ptr to be in ps at all times, even after return from a->b->a segment flow. */ 1639 1640 if alloc_ps 1641 then do; 1642 builtins (2) = create_node (symbol_node, size (symbol)); 1643 psp = addr (rands (builtins (2))); 1644 psp -> symbol.operand_type = dummy; 1645 psp -> symbol.by_compiler = "1"b; 1646 psp -> symbol.automatic, psp -> symbol.allocate, psp -> symbol.allocated, psp -> symbol.is_addressable, 1647 psp -> symbol.ext_base = "1"b; 1648 psp -> symbol.base = sp; 1649 psp -> symbol.reloc = rc_a; 1650 last_auto_loc = divide (last_auto_loc + 1, 2, 17, 0) * 2; 1651 /* EVEN WORD NEEDED */ 1652 call assign_address_offset (psp, last_auto_loc, 48, word_units); 1653 last_auto_loc = last_auto_loc + 48; 1654 if last_auto_loc > max_stack_size 1655 then call print_message (414, "in making parameter storage for IO the stack frame", max_stack_size - bias); 1656 1657 /* Build a symbol that overlays the PS at the field buffer_p (offset 20b3). This symbol 1658* is used to load the value of this pointer by the object segment. */ 1659 1660 builtins (10) = create_node (symbol_node, size (symbol)); 1661 psap = addr (rands (builtins (10))); 1662 psap -> symbol = psp -> symbol; /* use PS symbol as template to create this one */ 1663 psap -> symbol.address.offset = psap -> symbol.address.offset + 16; 1664 /* = 20b3 */ 1665 end; 1666 1667 else builtins (2), builtins (10) = 0; 1668 1669 /* If a cleanup body is needed, allocate it. */ 1670 1671 if alloc_auto_cleanup 1672 then do; 1673 cleanup_body_address = create_node (symbol_node, size (symbol)); 1674 clp = addr (rands (cleanup_body_address)); 1675 clp -> symbol.operand_type = dummy; 1676 clp -> symbol.by_compiler = "1"b; 1677 clp -> symbol.automatic, clp -> symbol.allocate, clp -> symbol.allocated, clp -> symbol.is_addressable, 1678 clp -> symbol.ext_base = "1"b; 1679 clp -> symbol.base = sp; 1680 clp -> symbol.reloc = rc_a; 1681 last_auto_loc = divide (last_auto_loc + 1, 2, 17, 0) * 2; 1682 /* EVEN WORD NEEDED */ 1683 call assign_address_offset (clp, last_auto_loc, 8, word_units); 1684 cleanup_body_address = last_auto_loc; 1685 last_auto_loc = last_auto_loc + 8; 1686 if last_auto_loc > max_stack_size 1687 then call print_message (414, "in making cleanup body the stack frame", max_stack_size - bias); 1688 end; 1689 else cleanup_body_address = 0; 1690 1691 /* Allocate space for all VLA COMMON */ 1692 1693 call allocate_VLA_common; 1694 1695 /* All subprograms done, relocate auto & static items */ 1696 1697 link_pos = divide (size (virgin_linkage_header) + linkage_pad + 1, 2, 18, 0) * 2; 1698 first_auto_var_loc = last_auto_loc; 1699 1700 /* now relocate all other static and auto items */ 1701 1702 call relocate (1, last_auto_loc, max_stack_size, "stack frame"); 1703 call relocate (5, link_pos, max_linkage_size, "linkage section"); 1704 1705 /* allocate profile space, if -profile */ 1706 1707 if generate_profile 1708 then do; 1709 profile_start, profile_pos = link_pos; 1710 if generate_long_profile 1711 then do; 1712 profile_pos = size (long_profile_header); 1713 link_pos = link_pos + size (long_profile_header) + size (long_profile_entry) * (profile_size + 1); 1714 end; 1715 else link_pos = link_pos + size (profile_entry) * (profile_size + 1); 1716 1717 link_pos = link_pos + mod (link_pos, 2); 1718 if link_pos > max_linkage_size 1719 then call print_message (414, "when allocating PROFILE information the linkage section", 1720 char (max_linkage_size)); 1721 end; 1722 1723 /* Finally, relocate common + external refs */ 1724 1725 begin_links = link_pos; 1726 1727 do cur_subprogram = first_subprogram repeat cs -> subprogram.next_subprogram while (cur_subprogram > 0); 1728 cs = addr (rands (cur_subprogram)); 1729 call get_subr_options (cs); 1730 1731 /* relocate external refs for VLA common */ 1732 1733 do hdr = cs -> subprogram.storage_info.first (17) repeat h -> node.next while (hdr > 0); 1734 h = addr (rands (hdr)); 1735 h -> node.location = h -> node.location + link_pos; 1736 end; 1737 1738 /* relocate common and external */ 1739 do hdr = cs -> subprogram.storage_info.first (9) repeat h -> node.next while (hdr > 0); 1740 h = addr (rands (hdr)); 1741 1742 if h -> node.node_type = header_node 1743 then do; 1744 h -> node.location = h -> node.location + link_pos; 1745 do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 1746 s = addr (rands (sym)); 1747 call assign_address_offset (s, 0, (s -> symbol.element_size), (s -> symbol.units)); 1748 end; 1749 end; 1750 1751 else do; 1752 if h -> symbol.initial = 0 1753 then call assign_address_offset (h, link_pos, 2, word_units); 1754 else h -> symbol.allocated = "0"b; 1755 end; 1756 end; 1757 1758 1759 end; 1760 1761 1762 /* Relocate the link pointer in the 'create_entry' for common. */ 1763 1764 call VLA_reloc_common_link; 1765 1766 1767 if generate_symtab 1768 then call assign_address_offset (ssp, link_pos, 2, word_units); 1769 1770 link_pos = link_pos + (next_free_polish - begin_external_list) - ((next_free_polish - begin_external_list) / 3); 1771 /* i.e., two words per link */ 1772 if link_pos > max_linkage_size 1773 then call print_message (414, 1774 "after allocating SYMTAB space for " || addr (rands (cs -> subprogram.symbol)) -> symbol.name 1775 || " the linkage section", char (max_linkage_size)); 1776 1777 return; 1778 1779 alloc_external: 1780 procedure (pt) returns (fixed binary (18)); 1781 1782 /* Searches the external_list to see if a common block or 1783* external reference has already been allocated before 1784* allocating a new link to it. 1785* 1786* The current implementation for the external list consists of 1787* three items per external variable. The first item is a pointer 1788* to a symbol node (for external entry points) or a pointer to 1789* a header node (for common blocks). The second item is only 1790* used for common blocks and specifies the (maximum) length for 1791* the common block. The third item is also only used for common 1792* block and indicates the units (words or characters of the 1793* maximum length. */ 1794 1795 dcl (p, pt) pointer; 1796 dcl loc fixed binary (18); 1797 dcl i fixed binary (18); 1798 dcl ceil builtin; 1799 dcl header_length fixed binary (24); 1800 1801 p = pt; 1802 1803 if p -> node.node_type = symbol_node 1804 then do i = begin_external_list to next_free_polish - 1 by 3; 1805 if ext_ref (i) -> node.node_type = symbol_node 1806 then if p -> symbol.name = ext_ref (i) -> symbol.name 1807 then return (ext_ref (i) -> symbol.location); 1808 end; 1809 1810 else do i = begin_external_list to next_free_polish - 1 by 3; 1811 if ext_ref (i) -> node.node_type = header_node 1812 then if p -> header.block_name = ext_ref (i) -> header.block_name 1813 then do; 1814 loc = ext_ref (i) -> header.location; 1815 1816 if p -> header.block_name = blank_common_name 1817 then do; 1818 if p -> header.units = polish (i + 2) 1819 then header_length = p -> header.length; 1820 else if polish (i + 2) = word_units 1821 then header_length = ceil (p -> header.length / 4); 1822 else header_length = p -> header.length * 4; 1823 /* change to character units */ 1824 if header_length > polish (i + 1) 1825 /* current max length */ 1826 then polish (i + 1) = header_length; 1827 /* update max length for unlabelled common */ 1828 end; 1829 else do; 1830 if p -> header.units = polish (i + 2) 1831 then header_length = p -> header.length; 1832 else if polish (i + 2) = word_units 1833 then header_length = ceil (p -> header.length / 4); 1834 else header_length = p -> header.length * 4; 1835 /* change to character units */ 1836 if header_length > polish (i + 1) 1837 /* current max length for block */ 1838 then do; 1839 polish (i + 1) = header_length; 1840 /* update length for common block */ 1841 if polish (i + 2) = word_units 1842 then call print_message (426, fixed (rel (p), 18), ltrim (char (header_length)), 1843 "words"); 1844 else call print_message (426, fixed (rel (p), 18), ltrim (char (header_length)), 1845 "characters"); 1846 end; 1847 else if header_length < polish (i + 1) 1848 /* check for different length */ 1849 then call print_message (434, fixed (rel (p), 18)); 1850 1851 if p -> header.initialed 1852 then if ext_ref (i) -> header.initialed 1853 then call print_message (432, fixed (rel (p), 18)); 1854 else ext_ref (i) = p; 1855 end; 1856 1857 return (loc); 1858 end; 1859 end; 1860 1861 /* allocate new entry in external list */ 1862 1863 if next_free_polish + 2 < polish_max_len 1864 then do; 1865 ext_ref (next_free_polish) = p; 1866 1867 if p -> node.node_type = header_node /* for common blocks, save block length */ 1868 then do; 1869 polish (next_free_polish + 1) = p -> header.length; 1870 polish (next_free_polish + 2) = p -> header.units; 1871 end; 1872 next_free_polish = next_free_polish + 3; 1873 1874 loc = link_pos; 1875 link_pos = link_pos + 2; 1876 if link_pos > max_linkage_size 1877 then call print_message (414, "linkage section", char (max_linkage_size)); 1878 1879 return (loc); 1880 end; 1881 1882 else call print_message (407, "polish region", char (polish_max_len)); 1883 1884 end alloc_external; 1885 1886 alloc_members: 1887 procedure (); 1888 1889 /* Allocates members of common blocks and equivalence groups. */ 1890 1891 do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 1892 s = addr (rands (sym)); 1893 substr (string (s -> symbol.storage_class), 1, 3) = string (h -> header.storage_class); 1894 unspec (s -> symbol.address) = unspec (h -> header.address); 1895 s -> symbol.reloc = h -> header.reloc; 1896 if s -> symbol.units = char_units 1897 then do; 1898 s -> symbol.location = h -> header.location + divide (s -> symbol.offset, chars_per_word, 18, 0); 1899 s -> symbol.address.char_num = mod (s -> symbol.offset, chars_per_word); 1900 end; 1901 else s -> symbol.location = h -> header.location + s -> symbol.offset; 1902 s -> symbol.operand_type = variable_type; 1903 string (s -> symbol.addressing_bits) = string (h -> header.addressing_bits); 1904 s -> symbol.hash_chain = 0; 1905 if s -> symbol.dimensioned 1906 then vsize = get_array_size (s); 1907 end; 1908 1909 end alloc_members; 1910 1911 create_storage_entry: 1912 proc (h); 1913 1914 /* Purpose: Create a creation list entry in the text section, and link it to 1915* the last such entry. Information required is taken from the chain 1916* header supplied. */ 1917 1918 1919 dcl h ptr; /* Incoming header pointer */ 1920 1921 dcl cur_pos fixed bin (18) unsigned; /* current position in text section */ 1922 dcl listp ptr; 1923 dcl i fixed bin; 1924 1925 1926 dcl (currentsize, length) builtin; 1927 1928 call make_create_entry (h); 1929 1930 if h -> header.VLA /* setup pointers */ 1931 then do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 1932 s = addr (rands (sym)); 1933 if s -> symbol.offset = 0 & VLA_is_256K 1934 then call set_address_offset (s, (h -> header.location), 1, word_units); 1935 else do; 1936 listp -> create_entry.pointer_count = listp -> create_entry.pointer_count + 1; 1937 call set_address_offset (s, h -> header.location + listp -> create_entry.pointer_count, 1, 1938 word_units); 1939 listp -> create_entry.pointer_offsets (listp -> create_entry.pointer_count).offset = 1940 s -> symbol.offset; 1941 if h -> header.static 1942 then linkage_pad = linkage_pad + 1; 1943 else last_auto_loc = last_auto_loc + 1; 1944 1945 /* save the symbol name for the listing */ 1946 if assembly_list 1947 then do; 1948 cur_pos = 1949 fixed ( 1950 rel ( 1951 addr (listp -> create_entry.pointer_offsets (listp -> create_entry.pointer_count)))); 1952 a_name (cur_pos) = fixed (rel (s)); 1953 end; 1954 end; 1955 end; 1956 1957 /* increment past all information */ 1958 1959 text_pos = text_pos + currentsize (listp -> create_entry); 1960 return; 1961 1962 note_VLA_common: 1963 entry (h); 1964 1965 1966 /* Take note of common blocks in VLA common, and combine them into single 1967* composite representations for each common of every definition of that 1968* common. This means determining the maximum length, the number of unique 1969* offsets into the common (to build pointer information), and any init 1970* information. */ 1971 1972 dcl chain_head ptr; /* head of current chain */ 1973 dcl hdr ptr; /* current entry node */ 1974 dcl looping bit (1); /* scanning chain */ 1975 dcl s ptr; /* current symbol */ 1976 dcl sym fixed bin (18); /* current symbol node */ 1977 dcl this_chain ptr; /* last header of current chain */ 1978 1979 1980 /* entry for headers and symbols. */ 1981 1982 dcl 1 entry based (hdr), 1983 2 next ptr, /* next entry in header list */ 1984 2 chain ptr, /* next entry in chain */ 1985 2 node ptr, /* pointer node in rands */ 1986 2 header bit (1) unaligned, /* node is a header */ 1987 2 offset fixed bin (35) unsigned unaligned; /* symbol offset */ 1988 1989 if first_header = null () /* no list */ 1990 then goto create_header; 1991 1992 /* find header chain. */ 1993 1994 do hdr = first_header repeat entry.next while (hdr ^= null ()); 1995 if entry.node -> header.block_name = h -> header.block_name 1996 then goto add_header; /* in right chain */ 1997 end /* do hdr */; 1998 1999 /* at this point we don't have the right chain, but we do have a list */ 2000 2001 if hdr = null () 2002 then do; 2003 2004 create_header: 2005 call make_entry; 2006 if first_header = null () /* chain to list */ 2007 then first_header = hdr; 2008 else last_header -> entry.next = hdr; 2009 last_header = hdr; 2010 end; 2011 else do; /* cannot enter through the do, it is just for blocking */ 2012 2013 /* form maximum length */ 2014 2015 add_header: 2016 chain_head = hdr; 2017 if h -> header.length ^= entry.node -> header.length 2018 then do; 2019 2020 /* form maximum common block lengths */ 2021 2022 if h -> header.block_name ^= blank_common_name 2023 then if h -> header.length > entry.node -> header.length 2024 then call print_message (426, fixed (rel (h), 18), ltrim (char (h -> header.length))); 2025 else call print_message (434, fixed (rel (h), 18)); 2026 2027 if h -> header.length > entry.node -> header.length 2028 then h -> header.length = entry.node -> header.length; 2029 end; 2030 2031 2032 /* find end of headers in chain list. */ 2033 2034 do hdr = chain_head repeat entry.chain while (entry.chain -> entry.header = "1"b); 2035 end; /* leave hdr pointing at last header of chain */ 2036 2037 /* Link new entry into chain as last header in header portion of chain */ 2038 2039 this_chain = hdr; 2040 call make_entry; 2041 entry.chain = this_chain -> entry.chain; 2042 this_chain -> entry.chain = hdr; 2043 end; 2044 2045 2046 /* Add list of symbols to chain. Last header of chain is at 'hdr' */ 2047 /* This leaves a list sorted by symbol offset. */ 2048 2049 add_symbols: 2050 chain_head = hdr; 2051 do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 2052 s = addr (rands (sym)); 2053 2054 /* add total if chain is empty of symbols. */ 2055 2056 this_chain = chain_head; 2057 if this_chain -> entry.chain ^= null () 2058 then do; 2059 looping = "1"b; 2060 do while (looping); 2061 this_chain = this_chain -> entry.chain; 2062 if this_chain -> entry.chain = null () 2063 then looping = "0"b; 2064 else if this_chain -> entry.chain -> entry.offset > s -> symbol.offset 2065 then looping = "0"b; 2066 end; 2067 end; 2068 2069 /* hdr points at add_point to chain */ 2070 2071 call make_entry; 2072 entry.offset = s -> symbol.offset; 2073 entry.chain = this_chain -> entry.chain; 2074 entry.node = s; 2075 entry.header = "0"b; 2076 this_chain -> entry.chain = hdr; 2077 end /* do sym */; 2078 return; 2079 2080 /* Assign Storage to VLA common. */ 2081 allocate_VLA_common: 2082 entry; 2083 2084 /* Assign storage address and storage creation information. This is done 2085* by scanning the finalized lists and copying the maximum length through all 2086* headers for the multiple uses of that common, then creating a storage 2087* creation entry for the common, and then assigning a pointer location 2088* to each unique offset, and copying that pointer location into the symbols 2089* mapped into that unique offset. At the same point a storage creation 2090* pointer is created and assigned that offset. Initialization information 2091* is picked up in a separate pass through the symbols. */ 2092 2093 dcl common_length fixed bin (35); /* common_length of the common block */ 2094 dcl current_offset fixed bin (35); /* current symbol offset processing */ 2095 dcl location fixed bin (18); /* location of packed pointers */ 2096 2097 /* scan commons */ 2098 2099 do chain_head = first_header repeat chain_head while (chain_head ^= null ()); 2100 2101 /* pick up the maximum length and propagate it through the multiple copies of headers */ 2102 2103 common_length = chain_head -> entry.node -> header.length; 2104 2105 /* 'header.location' is the normal location in which the 2106* external link would be found and will be later relocated 2107* and external reference made. */ 2108 2109 /* At this point header.location is the pointer to the first PP. */ 2110 2111 /* NOTE - you will see the strange construction 'copy ("0"b, 18 - length (x)) || x' 2112* in setting 'reloc_halfs' in this code. This is because of the use to two 2113* different definitions for 'rc_t' and 'rc_lp18', one for 6-bits and the 2114* other for 18-bits. Why they have the same name I do not know, but I do know 2115* that the binder is very unhappy to receive a 6-bit relocation value left 2116* adjusted in an 18-bit field, hence the padding. If some turkey changes the 2117* definition in the future, and I get the 18-bitter, it will still work. */ 2118 2119 location, chain_head -> entry.node -> header.location = linkage_pad + size (virgin_linkage_header); 2120 linkage_pad = linkage_pad + 1; /* space for base addressor */ 2121 call make_create_entry (chain_head -> entry.node); 2122 chain_head -> entry.node -> header.location, listp -> create_entry.common_link = 2123 alloc_external (chain_head -> entry.node); 2124 reloc_halfs (text_pos + 3).left = copy ("0"b, 18 - length (rc_lp18)) || rc_lp18; 2125 call set_address_offset (addr (rands (chain_head -> entry.node -> header.VLA_base_addressor)), (location), 2126 1, word_units); 2127 2128 do hdr = chain_head -> entry.chain repeat entry.chain while (entry.header = "1"b); 2129 entry.node -> header.length = common_length; 2130 entry.node -> header.location = alloc_external (entry.node); 2131 call set_address_offset (addr (rands (entry.node -> header.VLA_base_addressor)), (location), 1, 2132 word_units); 2133 end; 2134 2135 if VLA_is_256K 2136 then current_offset = 0; /* Base addressor is a packed ptr to offset 0. */ 2137 else current_offset = -1; /* Base addressor is logical address of offset 0. */ 2138 i = 0; /* current pointer */ 2139 do hdr = hdr repeat entry.chain while (hdr ^= null ()); 2140 s = entry.node; 2141 if s -> symbol.offset ^= current_offset 2142 then i = i + 1; /* count unique pointer */ 2143 call set_address_offset (s, location + i, 1, word_units); 2144 2145 /* Save a copy of the offset information */ 2146 s -> symbol.addr_hold = substr (unspec (s -> symbol.address), 1, 18); 2147 2148 /* create a pointer for all but possibly the first unique entry */ 2149 2150 if s -> symbol.offset ^= current_offset 2151 then do; 2152 current_offset = s -> symbol.offset; 2153 listp -> create_entry.pointer_count = i; 2154 listp -> create_entry.pointer_offsets (i).offset = s -> symbol.offset; 2155 linkage_pad = linkage_pad + 1; 2156 2157 /* save the symbol name for the listing */ 2158 if assembly_list 2159 then do; 2160 cur_pos = fixed (rel (addr (listp -> create_entry.pointer_offsets (i)))); 2161 a_name (cur_pos) = fixed (rel (s)); 2162 end; 2163 end /* do */; 2164 end /* do hdr */; 2165 2166 text_pos = text_pos + currentsize (listp -> create_entry); 2167 2168 chain_head = chain_head -> entry.next; 2169 end /* do chain_head */; 2170 2171 call cleanup_VLA_common; /* Use common cleanup */ 2172 return; 2173 2174 /* Entry to relocate the link relative offset left in the create_entry for 2175* common VLA, to become a true linkage section offset. */ 2176 2177 VLA_reloc_common_link: 2178 entry; 2179 2180 2181 looping = "1"b; /* loop through list */ 2182 2183 location = Area_create_first; 2184 if Area_create_first ^= -1 2185 then do while (looping = "1"b); 2186 listp = addrel (object_base, location); 2187 if listp -> create_entry.common 2188 then listp -> create_entry.common_link = listp -> create_entry.common_link + link_pos; 2189 location = listp -> create_entry.next; 2190 if location = 0 2191 then looping = "0"b; 2192 end; 2193 return; 2194 2195 2196 2197 cleanup_VLA_common: 2198 entry; 2199 2200 /* Cleanup vla common allocation lists when cleanup encountered. */ 2201 2202 if first_header = null () 2203 then return; 2204 2205 do first_header = first_header repeat first_header while (first_header ^= null ()); 2206 chain_head = first_header; 2207 first_header = first_header -> entry.next; 2208 do this_chain = chain_head repeat this_chain while (this_chain ^= null ()); 2209 hdr = this_chain; 2210 this_chain = entry.chain; 2211 free entry; 2212 end /* do this_chain */; 2213 end /* do first_header */; 2214 2215 return /* cleanup_VLA_common */; 2216 2217 2218 /* create an entry for a header/symbol */ 2219 make_entry: 2220 proc; 2221 2222 allocate entry; 2223 entry.node = h; 2224 entry.chain, entry.next = null (); 2225 entry.offset = 0; 2226 entry.header = "1"b; 2227 return; 2228 end make_entry; /* Make the basic creation list entry. */ 2229 make_create_entry: 2230 proc (h); 2231 2232 dcl h ptr; 2233 dcl i fixed bin (18); /* index in text */ 2234 dcl last_listp ptr; /* -> last create_entry */ 2235 2236 listp = addrel (object_base, text_pos); 2237 2238 /* Set location of base pointer in section and set relocation of pointer */ 2239 2240 listp -> create_entry.location = h -> header.location; 2241 if h -> header.static | h -> header.in_common 2242 then reloc_halfs (text_pos).left = copy ("0"b, 18 - length (rc_is15)) || rc_is15; 2243 else if h -> header.automatic 2244 then reloc_halfs (text_pos).left = copy ("0"b, 18 - length (rc_a)) || rc_a; 2245 2246 listp -> create_entry.auto = h -> header.automatic; 2247 listp -> create_entry.static = h -> header.static; 2248 listp -> create_entry.common = h -> header.in_common; 2249 listp -> create_entry.LA = h -> header.LA; 2250 listp -> create_entry.VLA = h -> header.VLA; 2251 listp -> create_entry.K256 = VLA_is_256K; 2252 listp -> create_entry.init = h -> header.initialed; 2253 listp -> create_entry.length = h -> header.length; 2254 listp -> create_entry.next = 0; 2255 listp -> create_entry.name_length = h -> header.name_length; 2256 if listp -> create_entry.name_length ^= 0 2257 then listp -> create_entry.block_name = h -> header.block_name; 2258 2259 listp -> create_entry.pointer_count = 0; 2260 2261 if h -> header.automatic 2262 then alloc_auto_cleanup = "1"b; /* cleanup automatic LA's and VLA's */ 2263 2264 if Area_create_first < 0 /* flagged empty */ 2265 then Area_create_first = text_pos; 2266 else do; 2267 2268 /* Link previous entry to this one and set relocation too. */ 2269 2270 last_listp = addrel (object_base, Area_create_last); 2271 last_listp -> create_entry.next = text_pos; 2272 i = fixed (rel (addr (last_listp -> create_entry.next)), 18, 0) - fixed (rel (object_base), 18, 0); 2273 reloc_halfs (i).left = copy ("0"b, 18 - length (rc_t)) || rc_t; 2274 end; 2275 Area_create_last = text_pos; 2276 2277 end make_create_entry; 2278 end create_storage_entry; 2279 2280 relocate: 2281 procedure (which, locn, limit, section_name); 2282 2283 /* Relocates items in each bucket. */ 2284 2285 dcl which fixed binary (18), 2286 locn fixed binary (18), 2287 limit fixed binary (18), /* limit of section */ 2288 section_name char (*); /* name of section */ 2289 2290 dcl (i, loc, start) fixed binary (18); 2291 2292 loc = locn; 2293 2294 do start = which to which + 2 by 2; 2295 do cur_subprogram = first_subprogram repeat cs -> subprogram.next_subprogram while (cur_subprogram > 0); 2296 cs = addr (rands (cur_subprogram)); 2297 call get_subr_options (cs); 2298 2299 do i = start to start + 1; 2300 cs -> subprogram.next_loc (i) = cs -> subprogram.next_loc (i) + loc; 2301 2302 do hdr = cs -> subprogram.storage_info.first (i) repeat h -> node.next while (hdr > 0); 2303 h = addr (rands (hdr)); 2304 2305 if h -> node.node_type = header_node 2306 then do; 2307 call assign_address_offset (h, loc, 1, word_units); 2308 do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 2309 s = addr (rands (sym)); 2310 call relocate_error (s); 2311 call assign_address_offset (s, loc, (s -> symbol.element_size), 2312 (s -> symbol.units)); 2313 end; 2314 end; 2315 2316 else do; 2317 call relocate_error (h); 2318 call assign_address_offset (h, loc, (h -> symbol.element_size), (h -> symbol.units)); 2319 end; 2320 end; 2321 2322 loc = cs -> subprogram.next_loc (i); 2323 end; 2324 2325 loc = loc + mod (loc, 2); 2326 end; 2327 end; 2328 2329 locn = loc; 2330 2331 /* Test if variable will fit within region. */ 2332 2333 relocate_error: 2334 proc (s); 2335 2336 dcl s ptr; /* pointer to node */ 2337 dcl next_loc fixed bin (18); 2338 2339 if s -> node.next ^= 0 2340 then next_loc = addr (rands (s -> node.next)) -> node.location; 2341 else next_loc = cs -> subprogram.next_loc (i) - loc; 2342 2343 if loc + next_loc > limit 2344 then call print_message (414, 2345 "with relocation of " || s -> symbol.name || " in " 2346 || addr (rands (cs -> subprogram.symbol)) -> symbol.name || " the " || section_name, 2347 ltrim (char (limit))); 2348 end relocate_error; 2349 end relocate; 2350 2351 get_array_size: 2352 procedure (pt) returns (fixed binary (18)); 2353 2354 /* Calculates the size of an array, and computes its virtual 2355* origin if constant. */ 2356 2357 dcl (pt, s, d) pointer; 2358 dcl (cm, i, n, v) fixed binary (18); 2359 dcl ndims fixed binary (3); 2360 dcl constant_vo bit (1) aligned; 2361 2362 n = 0; 2363 s = pt; 2364 d = addr (rands (s -> symbol.dimension)); 2365 2366 if ^s -> symbol.variable_extents & ^s -> symbol.star_extents 2367 then do; 2368 d -> dimension.array_size = d -> dimension.element_count * s -> symbol.element_size; 2369 d -> dimension.has_array_size = "1"b; 2370 n = get_size_in_words ((d -> dimension.array_size), (s -> symbol.units)); 2371 2372 /* calculate virtual origin */ 2373 2374 v = 0; 2375 cm = s -> symbol.element_size; 2376 do i = 1 to d -> dimension.number_of_dims; 2377 v = v + cm * d -> dimension.lower_bound (i); 2378 cm = cm * d -> dimension.size (i); 2379 end; 2380 2381 d -> dimension.virtual_origin = v; 2382 d -> dimension.has_virtual_origin = "1"b; 2383 end; 2384 2385 else do; 2386 2387 /* Make a descriptor for the array */ 2388 2389 if s -> symbol.needs_descriptors | s -> symbol.put_in_symtab | shared_globals.options.table 2390 then i = make_symbol_descriptor (fixed (rel (s), 18)); 2391 2392 /* Allocate a symbol for the array size */ 2393 2394 if ^d -> dimension.has_array_size 2395 then do; 2396 d -> dimension.array_size = create_automatic_integer (cs); 2397 d -> dimension.has_array_size = "1"b; 2398 d -> dimension.variable_array_size = "1"b; 2399 end; 2400 2401 ndims = d -> dimension.number_of_dims; 2402 2403 /* Allocate a virtual origin symbol if necessary */ 2404 2405 if ^d -> dimension.has_virtual_origin 2406 then do; 2407 constant_vo = ^d -> dimension.v_bound (ndims).lower; 2408 do i = 1 to ndims - 1 while (constant_vo); 2409 constant_vo = (string (d -> dimension.v_bound (i)) = "00"b); 2410 end; 2411 if ^constant_vo | s -> symbol.star_extents 2412 /* either case requires vo */ 2413 then do; 2414 d -> dimension.virtual_origin = create_automatic_integer (cs); 2415 d -> dimension.has_virtual_origin = "1"b; 2416 d -> dimension.variable_virtual_origin = "1"b; 2417 end; 2418 end; 2419 2420 /* Allocate symbols for dimension.size (*) */ 2421 2422 if ^d -> dimension.has_dim_sizes 2423 then do; 2424 do i = 1 to ndims - binary (d -> dimension.assumed_size, 1); 2425 if string (d -> dimension.v_bound (i)) = "00"b 2426 then d -> dimension.size (i) = 2427 d -> dimension.upper_bound (i) - d -> dimension.lower_bound (i) + 1; 2428 else if ^d -> dimension.v_bound (i).lower & d -> dimension.lower_bound (i) = 1 2429 then d -> dimension.size (i) = d -> dimension.upper_bound (i); 2430 else d -> dimension.size (i) = create_automatic_integer (cs); 2431 end; 2432 d -> dimension.has_dim_sizes = "1"b; 2433 end; 2434 2435 end; 2436 2437 return (n); 2438 2439 end get_array_size; 2440 2441 end assign_storage; 2442 2443 create_automatic_integer: 2444 procedure (cs) returns (fixed binary (18)); 2445 2446 /* Creates an automatic integer variable. */ 2447 2448 dcl sym fixed binary (18); 2449 dcl s pointer; 2450 dcl cs pointer; 2451 2452 sym = create_node (symbol_node, size (symbol)); 2453 s = addr (rands (sym)); 2454 s -> symbol.data_type = int_mode; 2455 s -> symbol.by_compiler, s -> symbol.integer, s -> symbol.allocate, s -> symbol.automatic = "1"b; 2456 s -> symbol.element_size = 1; 2457 s -> symbol.units = word_units; 2458 2459 addr (rands (cs -> subprogram.last_symbol)) -> node.next = sym; 2460 cs -> subprogram.last_symbol = sym; 2461 2462 return (sym); 2463 2464 end create_automatic_integer; 2465 2466 /**** CREATE_REL_CONSTANT ****/ 2467 2468 create_rel_constant: 2469 procedure (cs) returns (fixed binary (18)); 2470 2471 /* Creates a rel_constant */ 2472 2473 dcl cs pointer; /* current subprogram node */ 2474 2475 dcl var fixed binary (18); 2476 dcl p pointer; 2477 24 1 /* BEGIN INCLUDE FILE relocation_bits.incl.pl1 */ 24 2 24 3 /* This include file defines the relocation bits as bit (6) entities. See 24 4* also relbts.incl.pl1 and reloc_lower.incl.pl1. */ 24 5 24 6 dcl ( rc_a initial("000000"b), /* absolute */ 24 7 rc_t initial("010000"b), /* text */ 24 8 rc_nt initial("010001"b), /* negative text */ 24 9 rc_lp18 initial("010010"b), /* linkage, 18 bit */ 24 10 rc_nlp18 initial("010011"b), /* negative link, 18 bit */ 24 11 rc_lp15 initial("010100"b), /* linkage, 15 bit */ 24 12 rc_dp initial("010101"b), /* def section */ 24 13 rc_s initial("010110"b), /* symbol segment */ 24 14 rc_ns initial("010111"b), /* negative symbol */ 24 15 rc_is18 initial("011000"b), /* internal static 18 */ 24 16 rc_is15 initial("011001"b), /* internal static 15 */ 24 17 rc_lb initial("011000"b), /* link block */ 24 18 rc_nlb initial("011001"b), /* negative link block */ 24 19 rc_sr initial("011010"b), /* self relative */ 24 20 rc_e initial("011111"b)) /* escape */ 24 21 bit(6) int static options(constant); 24 22 24 23 /* END INCLUDE FILE relocation_bits.incl.pl1 */ 2478 2479 2480 var = create_node (label_node, size (label)); 2481 p = addr (rands (var)); 2482 2483 p -> label.operand_type = rel_constant; 2484 p -> label.reloc = rc_t; 2485 p -> label.referenced, p -> label.referenced_executable, p -> label.is_addressable = "1"b; 2486 2487 if cs ^= null 2488 then do; 2489 if cs -> subprogram.last_label = 0 2490 then cs -> subprogram.first_label = var; 2491 else addr (rands (cs -> subprogram.last_label)) -> label.next_label = var; 2492 cs -> subprogram.last_label = var; 2493 end; 2494 2495 return (var); 2496 2497 end create_rel_constant; 2498 2499 interpreter: 2500 procedure (p_analyzing); 2501 2502 /* Written by R. A. Barnes 1 January 1976 */ 2503 2504 dcl (analyzing, p_analyzing) bit (1) aligned; /* "1"b - Performing Register Usage Analysis 2505* `` and Global Register Allocation. */ 2506 2507 dcl base fixed bin (18); /* subscript of arg1 */ 2508 dcl top fixed bin (18); /* subscript of op1 */ 2509 2510 dcl cur_frame ptr; /* ptr to current procedure frame */ 2511 dcl mac_base ptr; /* ptr to base of macro segment */ 2512 2513 dcl cs ptr; /* ptr to current subprogram node */ 2514 dcl statement_ptr ptr; /* ptr to current opt_statement node */ 2515 dcl quad_ptr ptr; /* ptr to current operator node */ 2516 2517 dcl cur_lp ptr; /* ptr to current loop node */ 2518 dcl fu ptr; /* ptr to current flow_unit */ 2519 dcl lp_msp ptr; /* cur_lp -> loop.msp (mach state template) */ 2520 2521 dcl next_lp ptr; /* ptr to loop we are about to enter */ 2522 2523 dcl imac fixed bin (18); /* index into fort_opt_macros_ */ 2524 dcl iquad fixed bin (18); /* index into quadruples */ 2525 dcl next_operand fixed bin (18); /* Index to get next "scanned" operand. */ 2526 2527 dcl left fixed bin (18); /* left half of macro instructiin */ 2528 dcl mopnd fixed bin (18); /* operand index in macro instruction */ 2529 dcl mop fixed bin (18); 2530 2531 dcl next_free_opt_ms ptr; /* free chain of machine_state nodes in opt region */ 2532 2533 dcl avail_pregs fixed bin (4); /* number of ptr registers in the pool */ 2534 dcl avail_xregs fixed bin (4); /* number of index registers in the pool */ 2535 2536 dcl desc_temp_chain fixed binary (18) unsigned; 2537 dcl op_code fixed bin (18); 2538 2539 dcl discard fixed bin (18); 2540 dcl (i, k, n, op1, op2, next_base, relation, scan_proc, skip, temp, zarg, desc, eaq_name, sym) fixed bin (18); 2541 dcl regno fixed bin (3); 2542 dcl (cdt, dt, dt1, dt2) fixed bin (4); 2543 dcl xr fixed bin (3); 2544 dcl char1 character (1); 2545 2546 dcl (p, st, lbl, s) ptr; 2547 dcl (b1, b2, err_flag, state_discarded) bit (1) aligned; 2548 dcl bit3 bit (3) aligned; 2549 dcl bit6 bit (6) aligned; 2550 2551 dcl from_base_man bit (1) aligned; /* "1"b if base_man_load_pr is active */ 2552 2553 dcl stack (300) fixed bin (18); 2554 2555 dcl computed_virtual_origin (25) fixed binary (18); 2556 dcl virtual_origin_count fixed binary (17); 2557 2558 dcl i_loop fixed bin; /* index of loop being analyzed */ 2559 dcl loop_vector_p ptr; /* -> loop_vector */ 2560 dcl n_loops fixed bin (18); /* number of loops in loop_vector */ 2561 dcl max_operators fixed bin (18); /* length(obits) */ 2562 dcl max_sym fixed bin (18); /* length(bits) */ 2563 2564 dcl ( 2565 fort_opt_macros_$first_scan, 2566 fort_opt_macros_$abort_list, 2567 fort_opt_macros_$error_macro 2568 ) bit (36) aligned ext static; 2569 2570 dcl 1 fort_opt_macros_$interpreter_macros (4) aligned ext static, 2571 2 entry fixed bin (17) unal, 2572 2 pad fixed bin (17) unal; 2573 2574 dcl 1 fort_opt_macros_$operator_table (109) aligned ext static, 2575 2 entry fixed bin (17) unal, 2576 2 pad fixed bin (17) unal; 2577 2578 dcl 1 fort_instruction_info_$fort_instruction_info_ (0:1023) aligned ext static, 2579 2 alters unaligned structure, 2580 3 A bit (1), 2581 3 Q bit (1), 2582 3 indicators bit (1), 2583 3 PR (6) bit (1), 2584 3 XR bit (8), /* can't use (0:7) because of PL/I ERROR 338 */ 2585 3 pad1 bit (1), 2586 2 directable bit (1) unaligned, 2587 2 pad2 bit (17) unaligned; 2588 2589 dcl ( 2590 variable_count init (-1), 2591 not_given init (-2) 2592 ) fixed bin (18) int static options (constant); 2593 2594 dcl ERROR fixed bin (18) int static options (constant) init (-1); 2595 /* ERROR operand */ 2596 2597 dcl mask_left bit (36) aligned int static options (constant) init ("000000777777"b3); 2598 2599 dcl ( 2600 first_base initial (2), 2601 last_base initial (6), 2602 escape_index initial (1), 2603 first_index initial (2), 2604 last_index initial (7), 2605 linkage_ptr initial (36), 2606 arg_ptr initial (26), 2607 descriptor_ptr initial (34) 2608 ) fixed binary (18) internal static options (constant); 2609 2610 dcl 1 fort_opt_macros_$single_inst (158) aligned ext static like machine_instruction; 2611 25 1 /* BEGIN INCLUDE FILE fort_single_inst_names.incl.pl1 */ 25 2 25 3 /* This include file defines symbol names for the instructions defined in 25 4* fort_single_inst.incl.alm. 25 5* 25 6* Written: 6 October 1980 by C R Davis. 25 7* 25 8* Modified: 22 June 1984, M Mabey - Install typeless functions support. 25 9* Modified: 1 October 1982, T Oke - add packed pointer load, easp, eawp, 25 10* llr, als, div. 25 11* Modified: 20 September 1982, T Oke - To add packed pointer store, epaq, 25 12* qrl, stq and lrl. 25 13* Modified: 06 Jan 83, HH - Add 'lcq'. 25 14**/ 25 15 25 16 declare 25 17 ( 25 18 eax0 initial (1), 25 19 lxl0 initial (9), 25 20 lxl1 initial (10), 25 21 sxl0 initial (17), 25 22 load_base (6) initial (25, 26, 27, 28, 29, 30), 25 23 load_inst (10) initial (31, 32, 33, 34, 35, 36, 37, 32, 31, 32), 25 24 stq initial (38), 25 25 store_inst (9) initial (38, 39, 40, 41, 42, 43, 44, 39, 38), 25 26 sta initial (39), 25 27 ind_to_a (10) initial (45, 46, 47, 48, 49, 50, 51, 52, 86, 87), 25 28 adfx1 initial (53), 25 29 sbfx1 initial (54), 25 30 stz initial (55), 25 31 asq initial (56), 25 32 store_base (6) initial (57, 58, 59, 60, 61, 62), 25 33 a9bd initial (63), 25 34 aos initial (64), 25 35 compare_inst (9) initial (65, 66, 67, 68, 69, 70, 71, 66, 65), 25 36 store_no_round_inst (9) 25 37 initial (38, 39, 40, 72, 73, 74, 44, 39, 38), 25 38 load_ind initial (75), 25 39 store_ind initial (76), 25 40 round_inst (4:6) initial (77, 78, 77), 25 41 add_base (6) initial (79, 80, 81, 82, 83, 84), 25 42 mpy initial (85), 25 43 adlx0 initial (88), 25 44 sblx0 initial (96), 25 45 cmpx0 initial (104), 25 46 eaq initial (112), 25 47 qrs initial (113), 25 48 anq initial (114), 25 49 orq initial (115), 25 50 orsq initial (116), 25 51 nop initial (117), 25 52 getlp initial (118), 25 53 store_packed_base(6)initial (119, 120, 121, 122, 123, 124), 25 54 epaq initial (125), 25 55 lrl initial (126), 25 56 qrl initial (127), 25 57 load_packed_base(6) initial (128, 129, 130, 131, 132, 133), 25 58 load_segment_num(6) initial (134, 135, 136, 137, 138, 139), 25 59 load_word_num (6) initial (140, 141, 142, 143, 144, 145), 25 60 llr initial (146), 25 61 als initial (147), 25 62 div initial (148), 25 63 lcq initial (149), 25 64 era initial (150), 25 65 erq initial (151), 25 66 ersa initial (152), 25 67 ersq initial (153), 25 68 alr initial (154), 25 69 ana initial (155), 25 70 lrs initial (156), 25 71 qls initial (157), 25 72 lca initial (158) 25 73 ) fixed binary (18) internal static options (constant); 25 74 25 75 /* END INCLUDE FILE fort_single_inst_names.incl.pl1 */ 2612 2613 2614 dcl dt_from_reg (20) fixed bin (4) int static options (constant) 2615 init (1, 5, 4, 2, 3, 2, 2, 1, 7, 0, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5); 2616 2617 dcl eaq_name_to_reg (20) fixed bin internal static options (constant) 2618 init (2, 1, 3, 3, 3, 3, 2, 1, 2, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4); 2619 2620 dcl ( 2621 A initial (1), 2622 Q initial (2), 2623 EAQ initial (3), 2624 IND initial (4) 2625 ) fixed bin (18) internal static options (constant); 2626 2627 dcl ( 2628 in_q init (1), /* integer value in the Q */ 2629 in_a init (2), /* logical value in the A */ 2630 in_aq init (3), /* complex value in the AQ */ 2631 in_eaq init (4), /* real value in the EAQ */ 2632 in_deaq init (5), /* dp value in the EAQ */ 2633 in_ieaq init (6), /* imag value in EAQ */ 2634 in_iq init (7), /* second word of doubleword in Q */ 2635 in_ia init (8), /* integer value in the A */ 2636 in_tq init (9), /* typeless value in the Q */ 2637 in_ind init (10), /* wildcard for logical value in IND */ 2638 tze init (11), /* .eq. */ 2639 tnz init (12), /* .ne. */ 2640 tmi init (13), /* .lt. */ 2641 tpl init (14), /* .ge. */ 2642 tmoz init (15), /* .le. */ 2643 tpnz init (16), /* .gt. */ 2644 tnc init (17), /* j_l_s */ 2645 trc init (18), /* j_ge_s */ 2646 j_le_s init (19), /* j_le_s */ 2647 j_g_s init (20) /* j_g_s */ 2648 ) fixed bin (18) int static options (constant); 2649 2650 dcl ( /* op_base equ 361 */ 2651 VLA_words_per_seg initial (361 - 476), /* SPECIAL conversion */ 2652 allocate_char_string initial (361 + 0), 2653 reallocate_char_string initial (361 + 29), 2654 alloc_auto_adj initial (361 + 72), 2655 shorten_stack initial (361 + 163), 2656 long_profile initial (361 + 426), 2657 shorten_stack_protect_ind initial (361 + 451) 2658 ) fixed binary (14) internal static options (constant); 2659 2660 dcl shorten_stack_mask bit (14) aligned internal static options (constant) initial ("01000000010000"b); 2661 /* Reserve pr1,x1 */ 2662 2663 dcl highest_ind_state fixed bin options (constant) int static init (19); 2664 2665 dcl zero_for_dt (0:7) fixed bin (18); 2666 2667 dcl function fixed bin (18) int static init (13) options (constant); 2668 2669 dcl ( 2670 check_subscript init (1), 2671 subscript_mpy init (2), 2672 move_eis init (3), 2673 check_stringrange init (4) 2674 ) fixed bin (18) int static options (constant); 2675 2676 dcl entry_info_size fixed bin (18) int static init (7) options (constant); 2677 2678 dcl descriptor_mask_addr bit (36) aligned internal static options (constant) initial ("000250000100"b3); 2679 /* pr0|168 = 000077777777 */ 2680 2681 dcl (result, source) bit (72) aligned; 2682 2683 dcl based_integer fixed bin (35) based; 2684 2685 dcl 1 inst_address aligned like symbol.address; 2686 2687 dcl 1 saved_cat_address aligned like node.address automatic; 2688 dcl cat_offset_temp fixed binary (18); 2689 2690 dcl char_temp char (8); 2691 2692 dcl 1 base_man_args, 2693 2 code fixed bin (18), 2694 2 variable fixed bin (18), 2695 2 offset fixed bin (18); 2696 2697 dcl hold_pr_locks (6) bit (1) aligned; 2698 2699 dcl 1 loop_vector_st based (loop_vector_p) aligned, 2700 2 loop_vector (n_loops) pointer unaligned; 2701 2702 dcl bits bit (max_sym) based aligned; /* symbol bits */ 2703 dcl obits bit (max_operators) based aligned; /* operator bits */ 2704 2705 2706 dcl int_image fixed bin (35) based; 2707 dcl real_image float bin (27) based; 2708 dcl dp_image float bin (63) based; 2709 dcl cmpx_image complex float bin (27) based; 2710 dcl bit_image bit (72) aligned based; 2711 2712 dcl ind_word bit (36) aligned based; 2713 2714 dcl 1 current_ms like machine_state aligned; 2715 2716 dcl 1 loop_state based (lp_msp) aligned like machine_state; 2717 2718 dcl 1 proc_frame based (cur_frame) aligned, 2719 2 node_type fixed bin (4) unal, 2720 2 flags structure unaligned, 2721 3 func bit (1), 2722 3 scan_interpreter_frame, 2723 4 interpreter_called bit (1) unal, 2724 4 scan_called bit (1) unal, 2725 3 pad bit (28) unal, 2726 2 prev ptr unal, 2727 2 next ptr unal, 2728 2 return fixed bin (18), 2729 2 base fixed bin (18), 2730 2 error_label fixed bin (18), 2731 2 interpreter_return label local, 2732 2 nshort fixed bin (18), 2733 2 short (3) fixed bin (18); 2734 2735 /* BEGIN Register Analysis Database */ 2736 2737 dcl 1 ptr_data, 2738 2 local fixed bin, 2739 2 locked fixed bin, 2740 2 max_local fixed bin, 2741 2 max_locked fixed bin, 2742 2 n_global fixed bin, 2743 2 item_st structure aligned, 2744 3 item (100) ptr unaligned; 2745 2746 dcl last_pr_locked_for_pl1_ops_arg fixed bin (3); 2747 2748 dcl 1 index_data like ptr_data; 2749 2750 dcl ptr_hash_table (0:210) fixed bin (18); 2751 2752 /* END Register Analysis Database */ 2753 2754 dcl 1 hast based (addr (macro_instruction (imac))), 2755 2 instruction_word bit (36) aligned, 2756 2 half_array (100) fixed bin (17) unaligned; 2757 2758 dcl 1 macro_instruction (0:262143) based (mac_base) aligned, 2759 2 left fixed bin (17) unal, /* left half - label or integer */ 2760 2 operand fixed bin (3) unal, 2761 2 eaq_name fixed bin (5) unal, 2762 2 inhibit bit (1) unal, 2763 2 op_code bit (7) unal; 2764 2765 dcl 1 machine_instruction (0:262143) based (mac_base) aligned, 2766 2 operand fixed bin (3) unal, 2767 2 increment fixed bin (13) unal, 2768 2 op_code bit (10) unal, 2769 2 inhibit bit (1) unal, 2770 2 ext_base_and_tag unal, 2771 3 ext_base bit (1) unal, 2772 3 tag bit (6) unal; 2773 2774 dcl 1 macro_dt_inst (0:262143) based (mac_base) aligned, 2775 2 number fixed bin (17) unal, 2776 2 data_type fixed bin (9) unal, 2777 2 inhibit bit (1) unal, 2778 2 op_code bit (7) unal; 2779 2780 dcl 1 macro_bits_inst (0:262143) based (mac_base) aligned, 2781 2 left fixed bin (17) unal, 2782 2 bits bit (10) unal, 2783 2 inhibit bit (1) unal, 2784 2 op_code bit (7) unal; 2785 2786 dcl 1 macro_if_inst (0:262143) based (mac_base) aligned, 2787 2 left fixed bin (17) unal, 2788 2 operand fixed bin (3) unal, 2789 2 relation bit (3) unal, 2790 2 with fixed bin (2) unal, 2791 2 inhibit bit (1) unal, 2792 2 op_code bit (7) unal; 2793 2794 dcl 1 macro_regs_inst (0:262143) based (mac_base) aligned, 2795 2 regs bit (18) unal, 2796 2 pad bit (10) unal, 2797 2 inhibit bit (1) unal, 2798 2 op_code bit (7) unal; 2799 2800 dcl 1 macro_cond_inst (0:262143) based (mac_base) aligned, 2801 2 left bit (18) unal, 2802 2 operand bit (4) unal, 2803 2 pad bit (5) unal, 2804 2 if_test bit (1) unal, 2805 2 inhibit bit (1) unal, 2806 2 op_code bit (7) unal; 2807 2808 dcl 1 instruction (0:262143) aligned based (object_base), 2809 2 base bit (3) unal, 2810 2 offset fixed bin (14) unal, 2811 2 op bit (10) unal, 2812 2 inhibit bit (1) unal, 2813 2 ext_base_and_tag unal, 2814 3 ext_base bit (1) unal, 2815 3 tag bit (6) unal; 2816 2817 dcl text_word (0:262143) bit (36) aligned based (object_base); 2818 2819 dcl 1 reloc (0:262143) aligned based (relocation_base), 2820 2 skip1 bit (12) unal, 2821 2 left_rel bit (6) unal, 2822 2 skip2 bit (12) unal, 2823 2 right_rel bit (6) unal; 2824 2825 dcl 1 half based aligned, 2826 2 left fixed bin (17) unal, 2827 2 right fixed bin (17) unal; 2828 2829 dcl 1 arg_list auto aligned, 2830 2 header aligned, 2831 3 arg_count fixed bin (17) unal, 2832 3 code bit (18) unal, 2833 3 desc_count fixed bin (17) unal, 2834 3 pad bit (18) unal, 2835 2 itp_list (254) like itp aligned; /* Big enough for 127 args 2836* and descriptors */ 2837 2838 dcl 1 entry_descriptor aligned, 2839 2 type_bits bit (12) unaligned, 2840 2 char_size bit (24) unaligned; 2841 2842 dcl 1 floating_value auto aligned, 2843 2 exponent fixed binary (7) unaligned, 2844 2 mantissa bit (64) unaligned; 2845 2846 dcl mantissa_of_power_of_fpbase bit (64); 2847 2848 dcl (length, mod) builtin; 2849 26 1 /* BEGIN INCLUDE FILE relocation_bits.incl.pl1 */ 26 2 26 3 /* This include file defines the relocation bits as bit (6) entities. See 26 4* also relbts.incl.pl1 and reloc_lower.incl.pl1. */ 26 5 26 6 dcl ( rc_a initial("000000"b), /* absolute */ 26 7 rc_t initial("010000"b), /* text */ 26 8 rc_nt initial("010001"b), /* negative text */ 26 9 rc_lp18 initial("010010"b), /* linkage, 18 bit */ 26 10 rc_nlp18 initial("010011"b), /* negative link, 18 bit */ 26 11 rc_lp15 initial("010100"b), /* linkage, 15 bit */ 26 12 rc_dp initial("010101"b), /* def section */ 26 13 rc_s initial("010110"b), /* symbol segment */ 26 14 rc_ns initial("010111"b), /* negative symbol */ 26 15 rc_is18 initial("011000"b), /* internal static 18 */ 26 16 rc_is15 initial("011001"b), /* internal static 15 */ 26 17 rc_lb initial("011000"b), /* link block */ 26 18 rc_nlb initial("011001"b), /* negative link block */ 26 19 rc_sr initial("011010"b), /* self relative */ 26 20 rc_e initial("011111"b)) /* escape */ 26 21 bit(6) int static options(constant); 26 22 26 23 /* END INCLUDE FILE relocation_bits.incl.pl1 */ 2850 2851 2852 /* copy in parameter and set up */ 2853 2854 analyzing = p_analyzing; 2855 2856 if analyzing 2857 then do; 2858 unspec (ptr_hash_table), unspec (ptr_data), unspec (index_data) = "0"b; 2859 last_pr_locked_for_pl1_ops_arg = 0; 2860 avail_pregs = last_base - first_base + 1; 2861 avail_xregs = last_index - first_index + 1; 2862 end; 2863 2864 /* initialize cur_subprogram and friend */ 2865 2866 cur_subprogram = first_subprogram; 2867 2868 cur_statement = -1; 2869 2870 /* initialize constant builtins */ 2871 2872 builtins (0) = create_integer_constant (0); 2873 builtins (1) = create_integer_constant (1); 2874 builtins (5) = create_constant (dp_mode, unspec (null)); 2875 builtins (6) = 0; 2876 builtins (7) = create_integer_constant (2); 2877 2878 /* initialize array of zero constants */ 2879 2880 zero_for_dt (0) = ERROR; /* for invalid register states */ 2881 zero_for_dt (1) = builtins (0); /* integer */ 2882 addr (result) -> real_image = 0.0; 2883 zero_for_dt (2) = create_constant (real_mode, result); 2884 /* real */ 2885 addr (result) -> dp_image = 0.0; 2886 zero_for_dt (3) = create_constant (dp_mode, result); 2887 /* double precision */ 2888 addr (result) -> cmpx_image = 0.0; 2889 zero_for_dt (4) = create_constant (cmpx_mode, result); 2890 /* complex */ 2891 result = "0"b; 2892 zero_for_dt (5) = create_constant (logical_mode, result); 2893 /* logical */ 2894 zero_for_dt (6) = ERROR; /* character */ 2895 zero_for_dt (7) = builtins (0); /* typeless */ 2896 2897 /* initialize automatic vars for this program */ 2898 2899 call initialize_auto; 2900 2901 /* initialize builtins for auto template and overlay */ 2902 2903 char_constant_length = 0; /* do not allocate the value field */ 2904 2905 if builtins (3) = 0 2906 then do; 2907 builtins (3) = create_node (char_constant_node, size (char_constant)); 2908 p = addr (rands (builtins (3))); 2909 p -> char_constant.operand_type = constant_type; 2910 p -> char_constant.data_type = char_mode; 2911 p -> char_constant.is_addressable, p -> char_constant.allocated = "1"b; 2912 p -> char_constant.reloc = rc_t; 2913 p -> char_constant.length = 2914 chars_per_word * (addr (rands (last_subprogram)) -> subprogram.next_loc (2) - first_auto_var_loc); 2915 p -> char_constant.no_value_stored = "1"b; /* value is already in the text */ 2916 end; 2917 else p = addr (rands (builtins (3))); 2918 2919 p -> char_constant.location = auto_template; 2920 2921 if builtins (4) = 0 2922 then do; 2923 builtins (4) = create_node (array_ref_node, size (array_ref)); 2924 p = addr (rands (builtins (4))); 2925 p -> array_ref.operand_type = array_ref_type; 2926 p -> array_ref.data_type = char_mode; 2927 p -> array_ref.is_addressable, p -> array_ref.allocated, p -> array_ref.ext_base = "1"b; 2928 p -> array_ref.base = sp; 2929 p -> array_ref.address.offset = first_auto_var_loc; 2930 end; 2931 else p = addr (rands (builtins (4))); 2932 if init_auto_to_zero 2933 then p -> array_ref.length = chars_per_word * (last_auto_loc - first_auto_var_loc); 2934 else p -> array_ref.length = addr (rands (builtins (3))) -> char_constant.length; 2935 p -> array_ref.ref_count = 131071; /* prevent deletion */ 2936 2937 if builtins (8) = 0 2938 then do; 2939 builtins (8) = create_node (symbol_node, size (symbol)); 2940 p = addr (rands (builtins (8))); 2941 p -> symbol.operand_type = dummy; 2942 p -> symbol.by_compiler = "1"b; 2943 p -> symbol.allocated, p -> symbol.is_addressable, p -> symbol.ext_base = "1"b; 2944 p -> symbol.base = sp; 2945 end; 2946 2947 if builtins (11) = 0 2948 then do; 2949 builtins (11) = create_node (symbol_node, size (symbol)); 2950 p = addr (rands (builtins (11))); 2951 p -> symbol.operand_type = variable_type; 2952 p -> symbol.data_type = int_mode; 2953 p -> symbol.by_compiler = "1"b; 2954 p -> symbol.needs_pointer = "1"b; 2955 p -> symbol.descriptor = "1"b; 2956 p -> symbol.address.ext_base = "1"b; 2957 end; 2958 2959 /* perform other initializations */ 2960 2961 desc_temp_chain = 0; 2962 state_discarded = "1"b; 2963 unspec (current_ms) = "0"b; 2964 from_base_man = "0"b; 2965 next_free_opt_ms = null; 2966 if shared_globals.hfp 2967 then mantissa_of_power_of_fpbase = "00001"b; 2968 else mantissa_of_power_of_fpbase = "01"b; 2969 2970 /* initialize scanners */ 2971 2972 mac_base = ptr (addr (fort_opt_macros_$first_scan), 0); 2973 imac = fixed (rel (addr (fort_opt_macros_$first_scan)), 18) - 1; 2974 2975 /* get first procedure frame and initialize operand stack */ 2976 2977 if first_frame = null 2978 then do; 2979 cur_frame = null; 2980 2981 cur_frame, first_frame = create_proc_frame (); 2982 end; 2983 2984 else cur_frame = first_frame; 2985 2986 base, top = 0; 2987 2988 /* set up for subprogram */ 2989 2990 call start_subprogram; 2991 2992 /* MAIN LOOP! */ 2993 2994 do while ("1"b); 2995 2996 imac = imac + 1; 2997 2998 /* look at next instruction */ 2999 3000 loop: 3001 if ^macro_instruction (imac).inhibit 3002 then do; 3003 3004 /* have machine instruction */ 3005 3006 call emit_inst; 3007 go to step; 3008 end; 3009 3010 /* have macro instruction */ 3011 3012 mopnd = macro_instruction (imac).operand; 3013 left = macro_instruction (imac).left; 3014 mop = fixed (macro_instruction (imac).op_code, 7); 3015 3016 go to action (mop); 3017 3018 action (1): /* copy */ 3019 op1 = stack (get_operand (mopnd)); 3020 call copy (op1); 3021 go to step; 3022 3023 action (2): /* swap */ 3024 op1 = get_operand (mopnd); 3025 3026 k = stack (top); 3027 stack (top) = stack (op1); 3028 stack (op1) = k; 3029 3030 go to step; 3031 3032 action (3): /* pop */ 3033 op1 = get_operand (mopnd); 3034 call pop (op1); 3035 go to step; 3036 3037 action (4): /* push_temp */ 3038 dt = macro_dt_inst (imac).data_type; 3039 3040 if dt ^= 0 3041 then call push (assign_temp (dt)); 3042 3043 else do; 3044 3045 /* have block of words */ 3046 3047 if left < 0 3048 then do; 3049 3050 /* have count */ 3051 3052 b1 = "1"b; /* have count */ 3053 left = stack (top) + bias; 3054 top = top - 1; 3055 end; 3056 else b1 = "0"b; /* don't have count */ 3057 3058 call push (assign_block (left)); 3059 3060 /* if "push_temp var" then ref_count is infinite 78.03.29 */ 3061 3062 if b1 /* ref_count for var length temp is infinite 78.03.28 */ 3063 then if analyzing 3064 then addr (rands (stack (top))) -> temporary.ref_count_copy = 131071; 3065 else addr (rands (stack (top))) -> temporary.ref_count = 131071; 3066 end; 3067 3068 go to step; 3069 3070 action (6): /* dispatch for simple macro instructions */ 3071 go to simple (left); 3072 3073 simple (1): /* push_label */ 3074 simple (2): /* push_rel_constant */ 3075 call push (create_rel_constant (cs)); 3076 go to step; 3077 3078 action (8): /* push_constant */ 3079 dt = macro_dt_inst (imac).data_type; 3080 3081 if dt ^= 0 3082 then do; 3083 call push (create_constant (dt, addr (machine_instruction (imac + 1)) -> bit_image)); 3084 imac = imac + data_type_size (dt); 3085 end; 3086 3087 else do; 3088 if left < 0 3089 then do; 3090 left = stack (top) + bias; 3091 top = top - 1; 3092 end; 3093 call print_message (427, "push_constant_block"); 3094 end; 3095 3096 go to step; 3097 3098 action (9): /* convert_constant */ 3099 source = addr (rands (stack (top))) -> constant.value; 3100 cdt = addr (rands (stack (top))) -> constant.data_type; 3101 dt = macro_dt_inst (imac).data_type; 3102 result = conv_round (dt, cdt) ((source), 0); 3103 stack (top) = create_constant (dt, result); 3104 go to step; 3105 3106 action (54): /* push_count */ 3107 call push (left - bias); 3108 go to step; 3109 3110 action (10): /* push_count_indexed */ 3111 op1 = get_operand (mopnd); 3112 i = stack (op1) + bias; 3113 3114 if i <= 0 | i > left 3115 then call print_message (402, "push_count_indexed"); 3116 3117 call push (half_array (i) - bias); 3118 3119 imac = imac + divide (left + 1, 2, 17, 0); 3120 go to step; 3121 3122 action (11): /* push_builtin */ 3123 call push ((builtins (left))); 3124 go to step; 3125 3126 action (14): /* call without error exit */ 3127 action (70): /* call with error exit */ 3128 if mop = 14 3129 then call setup_call (left, imac, 0, 0); 3130 else do; 3131 imac = imac + 1; 3132 call setup_call (left, imac, (macro_instruction (imac).left), 0); 3133 end; 3134 3135 imac = left; 3136 go to step; 3137 3138 action (15): /* return */ 3139 if left = 0 3140 then do; 3141 3142 /* should be a proc invocation */ 3143 3144 if proc_frame.func 3145 then call print_message (403); 3146 3147 call pop (base); 3148 end; 3149 3150 else do; 3151 3152 /* should be a func invocation */ 3153 3154 if ^proc_frame.func 3155 then call print_message (404); 3156 3157 i = macro_instruction (imac).eaq_name; 3158 if i = 0 3159 then do; 3160 3161 /* return operand name */ 3162 3163 if proc_frame.scan_called 3164 then do; 3165 3166 /* When returning a temporary to the scan frame, 3167* copy the attributes of the returned temporary 3168* to the output temporary. When returning a 3169* non-temporary to the scan frame, replace 3170* instances of the output temporary by the 3171* returned operand. */ 3172 3173 op1 = stack (get_operand (mopnd)); 3174 3175 if op1 < 0 /* a count */ 3176 then op1 = create_integer_constant (op1 + bias); 3177 3178 if addr (rands (op1)) -> node.node_type ^= temporary_node 3179 then if op1 ^= quad_ptr -> operator.output 3180 then if addr (rands (quad_ptr -> operator.output)) -> node.node_type = temporary_node 3181 then call replace_inputs ((quad_ptr -> operator.output), op1); 3182 else call print_message (465); 3183 else ; /* Just pop */ 3184 else if op1 ^= quad_ptr -> operator.output 3185 then do; 3186 k = quad_ptr -> operator.output; 3187 3188 /* Copy relevant attributes from specified operand to output temporary of 3189* current operator. */ 3190 3191 call assign_address_to_temp (k, op1); 3192 3193 /* change occurances of op1 in machine state to k */ 3194 3195 if addr (rands (op1)) -> temporary.value_in.eaq 3196 then do; 3197 do regno = 1 to hbound (current_ms.eaq, 1); 3198 /* A, Q, EAQ, IND */ 3199 do i = 1 to current_ms.eaq (regno).number; 3200 if current_ms.eaq (regno).variable (i) = op1 3201 then current_ms.eaq (regno).variable (i) = k; 3202 end; 3203 end; 3204 3205 addr (rands (op1)) -> temporary.value_in.eaq = "0"b; 3206 addr (rands (k)) -> temporary.value_in.eaq = "1"b; 3207 end; 3208 3209 if addr (rands (op1)) -> temporary.value_in.x 3210 then do; 3211 do i = first_index to last_index; 3212 if current_ms.index_regs (i).type = 1 3213 then if current_ms.index_regs (i).variable = op1 3214 then current_ms.index_regs (i).variable = k; 3215 end; 3216 3217 addr (rands (op1)) -> temporary.value_in.x = "0"b; 3218 addr (rands (k)) -> temporary.value_in.x = "1"b; 3219 end; 3220 3221 if addr (rands (op1)) -> temporary.address_in_base 3222 then do; 3223 do i = first_base to last_base; 3224 if current_ms.base_regs (i).type = 1 3225 then if current_ms.base_regs (i).variable = op1 3226 then current_ms.base_regs (i).variable = k; 3227 end; 3228 3229 addr (rands (op1)) -> temporary.address_in_base = "0"b; 3230 addr (rands (k)) -> temporary.address_in_base = "1"b; 3231 end; 3232 3233 if current_ms.last_dynamic_temp = op1 3234 then current_ms.last_dynamic_temp = k; 3235 3236 end; 3237 3238 else call assign_address_to_temp (op1, 0); 3239 3240 call pop (base); 3241 end; 3242 3243 else do; /* Not the scan frame. */ 3244 op1 = get_operand (mopnd); 3245 k = stack (op1); 3246 stack (op1) = stack (base); 3247 if k < 0 3248 then stack (base) = create_integer_constant (k + bias); 3249 else stack (base) = k; 3250 3251 call pop (base + 1); 3252 end; 3253 end; 3254 3255 else do; 3256 3257 /* return eaq_name */ 3258 3259 call pop (base); 3260 3261 dt = dt_from_reg (i); 3262 3263 if proc_frame.scan_called 3264 then do; 3265 temp = quad_ptr -> operator.output; 3266 3267 call assign_address_to_temp (temp, 0); 3268 end; 3269 3270 else do; 3271 temp = assign_temp (dt); 3272 3273 call push (temp); 3274 end; 3275 3276 /* Note: return eaq_name should not be used to evaluate 3277* a function such as min or max since the indicators 3278* do not reflect the sign of the result. */ 3279 3280 call in_reg (temp, i); 3281 if i < in_ind 3282 then current_ms.indicators_valid = eaq_name_to_reg (i); 3283 3284 end; 3285 end; 3286 3287 p = cur_frame; 3288 3289 call pop_frame; 3290 3291 /* now, actually return */ 3292 3293 imac = p -> proc_frame.return; 3294 3295 if p -> proc_frame.interpreter_called 3296 then do; 3297 go to p -> proc_frame.interpreter_return; 3298 end; 3299 3300 go to step; 3301 3302 action (16): /* jump */ 3303 imac = left; 3304 go to loop; 3305 3306 action (17): /* scan */ 3307 rescan: 3308 quad_ptr = addr (quad (iquad)); 3309 iquad = quad_ptr -> operator.next; 3310 op_code = quad_ptr -> operator.op_code; 3311 scan_proc = fort_opt_macros_$operator_table (op_code).entry; 3312 3313 err_flag = quad_ptr -> operator.output = ERROR; 3314 /* To check for ERROR operands */ 3315 3316 next_operand = macro_dt_inst (scan_proc).data_type; 3317 if next_operand = variable_count 3318 then next_operand = quad_ptr -> operator.number; 3319 3320 do i = 1 by 1 while (i <= next_operand); 3321 if quad_ptr -> operator.operand (i) = ERROR 3322 then err_flag = "1"b; 3323 call push ((quad_ptr -> operator.operand (i))); 3324 end; 3325 3326 next_base = get_nextbase (scan_proc, next_operand); 3327 3328 if err_flag 3329 then do; 3330 3331 operand_is_ERROR: 3332 call pop (next_base); 3333 3334 if fixed (macro_instruction (scan_proc).op_code, 7) = function 3335 then call push (ERROR); 3336 3337 i = macro_instruction (scan_proc).left; 3338 if i = 0 3339 then go to rescan; 3340 3341 call setup_call (i, imac - 1, left, 0); 3342 imac = i; 3343 end; 3344 3345 else do; 3346 call setup_call (scan_proc, imac - 1, left, next_base); 3347 imac = scan_proc; 3348 end; 3349 3350 proc_frame.scan_called = "1"b; 3351 go to step; 3352 3353 action (19): /* s_call */ 3354 proc_frame.nshort = proc_frame.nshort + 1; 3355 if proc_frame.nshort > hbound (proc_frame.short, 1) 3356 then call print_message (407, "s_call stack", hbound (proc_frame.short, 1) - bias); 3357 else proc_frame.short (proc_frame.nshort) = imac; 3358 imac = left; 3359 go to loop; 3360 3361 simple (3): /* s_return */ 3362 if proc_frame.nshort < 0 3363 then call print_message (408); 3364 else do; 3365 imac = proc_frame.short (proc_frame.nshort); 3366 proc_frame.nshort = proc_frame.nshort - 1; 3367 end; 3368 3369 go to step; 3370 3371 action (21): /* if_dt */ 3372 b2 = "1"b; 3373 go to dt_join; 3374 3375 action (22): /* unless_dt */ 3376 b2 = "0"b; 3377 3378 dt_join: 3379 i = addr (rands (stack (top))) -> symbol.data_type; 3380 3381 if i <= 0 | i > length (macro_bits_inst (imac).bits) 3382 then call print_message (445, stack (top), "data_type"); 3383 else b1 = substr (macro_bits_inst (imac).bits, i, 1); 3384 3385 go to if_join; 3386 3387 action (23): /* if_optype */ 3388 b2 = "1"b; 3389 go to optype_join; 3390 3391 action (24): /* unless_optype */ 3392 b2 = "0"b; 3393 3394 optype_join: 3395 if stack (top) > 0 /* item can be operand or count */ 3396 then do; 3397 i = addr (rands (stack (top))) -> symbol.operand_type; 3398 /* an operand */ 3399 3400 if i <= 0 | i > length (macro_bits_inst (imac).bits) 3401 then do; 3402 call print_message (445, stack (top), "operand_type"); 3403 stop; 3404 end; 3405 end; 3406 3407 else i = count_type; /* a count */ 3408 3409 b1 = substr (macro_bits_inst (imac).bits, i, 1); 3410 3411 go to if_join; 3412 3413 action (25): /* (if unless)_array */ 3414 b2 = macro_cond_inst (imac).if_test; 3415 p = addr (rands (stack (top))); 3416 if p -> node.node_type = symbol_node 3417 then b1 = p -> symbol.dimensioned; 3418 else b1 = "0"b; 3419 go to if_join; 3420 3421 action (26): /* (if unless)_aligned */ 3422 b2 = macro_cond_inst (imac).if_test; 3423 p = addr (rands (stack (get_operand (mopnd)))); 3424 3425 if p -> node.units = char_units 3426 then do; 3427 if p -> node.node_type = symbol_node 3428 then if p -> symbol.parameter 3429 then b1 = "0"b; 3430 else b1 = (p -> symbol.address.char_num = 0); 3431 3432 else if p -> node.node_type = array_ref_node 3433 then if addr (rands (p -> array_ref.parent)) -> symbol.parameter 3434 then b1 = "0"b; 3435 else b1 = (p -> array_ref.address.char_num = 0 & ^cs -> subprogram.options.ansi_77); 3436 3437 else b1 = (p -> node.address.char_num = 0); 3438 end; 3439 else b1 = "1"b; 3440 3441 go to if_join; 3442 3443 action (27): /* if_eaq */ 3444 b2 = "1"b; 3445 go to eaq_join; 3446 3447 action (28): /* unless_eaq */ 3448 b2 = "0"b; 3449 3450 eaq_join: 3451 op1 = stack (get_operand (mopnd)); 3452 3453 if addr (rands (op1)) -> node.value_in.eaq 3454 then do; 3455 eaq_name = get_eaq_name (op1); 3456 if macro_instruction (imac).eaq_name = in_ind 3457 then b1 = (eaq_name > in_ind); 3458 else b1 = (eaq_name = macro_instruction (imac).eaq_name); 3459 end; 3460 3461 else b1 = "0"b; /* op1 not in any eaq register */ 3462 3463 3464 /* Modified 2/2/78 to drop ref count if the argument is in the eaq. */ 3465 3466 if b1 3467 then call drop_count (op1, 1); 3468 3469 go to if_join; 3470 3471 action (29): /* dt_jump */ 3472 dt1 = addr (rands (stack (top))) -> symbol.data_type; 3473 dt2 = addr (rands (stack (top - 1))) -> symbol.data_type; 3474 3475 if dt1 <= 0 3476 then call print_message (445, stack (top), "data_type"); 3477 3478 else if dt1 = typeless_mode 3479 then i = 19; 3480 3481 else if dt1 > cmpx_mode 3482 then i = 17; 3483 3484 else if dt2 <= 0 3485 then call print_message (445, stack (top - 1), "data_type"); 3486 3487 else if dt2 = typeless_mode 3488 then i = 20; 3489 3490 else if dt2 > cmpx_mode 3491 then i = 18; 3492 3493 else i = 4 * (dt1 - 1) + dt2; 3494 3495 imac = half_array (i); 3496 go to loop; 3497 3498 action (124): /* dt_jump1 */ 3499 dt = addr (rands (stack (get_operand (mopnd)))) -> symbol.data_type; 3500 3501 if dt <= 0 | dt > last_assigned_mode 3502 then do; 3503 call print_message (445, stack (get_operand (mopnd)), "data_type"); 3504 stop; 3505 end; 3506 3507 imac = half_array (dt); 3508 goto loop; 3509 3510 action (30): /* ind_jump */ 3511 if current_ms.eaq (IND).name < tze 3512 then call print_message (409); 3513 else imac = half_array (current_ms.eaq (IND).name - tze + 1); 3514 3515 go to loop; 3516 3517 action (72): /* if_ind */ 3518 b2 = "1"b; 3519 go to ind_join; 3520 3521 action (73): /* unless_ind */ 3522 b2 = "0"b; 3523 3524 ind_join: 3525 if current_ms.eaq (IND).name >= in_ind & current_ms.eaq (IND).number > 0 3526 then call print_message (410); 3527 3528 eaq_name = macro_instruction (imac).eaq_name; 3529 regno = eaq_name_to_reg (eaq_name); 3530 b1 = (current_ms.indicators_valid = regno); 3531 go to if_join; 3532 3533 action (81): /* (if unless)_parameter */ 3534 b2 = macro_cond_inst (imac).if_test; 3535 op1 = get_operand (mopnd); 3536 b1 = addr (rands (stack (op1))) -> symbol.parameter; 3537 go to if_join; 3538 3539 action (82): /* (if unless)_global */ 3540 b2 = macro_cond_inst (imac).if_test; 3541 op1 = stack (get_operand (mopnd)); 3542 b1 = addr (rands (op1)) -> node.globally_assigned; 3543 go to if_join; 3544 3545 action (83): /* (if unless)_induction_var */ 3546 b2 = macro_cond_inst (imac).if_test; 3547 p = addr (rands (stack (get_operand (mopnd)))); 3548 b1 = is_induction_var (p); 3549 go to if_join; 3550 3551 action (84): /* (if unless)_fb17 */ 3552 b2 = macro_cond_inst (imac).if_test; 3553 op1 = stack (get_operand (mopnd)); 3554 p = find_range (addr (rands (op1)), cur_lp); 3555 b1 = p -> range.fb17; 3556 go to if_join; 3557 3558 action (85): /* (if unless)_negative */ 3559 b2 = macro_cond_inst (imac).if_test; 3560 op1 = get_operand (mopnd); 3561 b1 = check_negative (stack (op1)); 3562 go to if_join; 3563 3564 action (86): /* (if unless)_global_ind_var */ 3565 b2 = macro_cond_inst (imac).if_test; 3566 p = addr (rands (stack (get_operand (mopnd)))); 3567 b1 = "0"b; 3568 if p -> node.globally_assigned 3569 then if is_induction_var (p) 3570 then b1 = "1"b; 3571 go to if_join; 3572 3573 action (87): /* (if unless)_local */ 3574 b2 = macro_cond_inst (imac).if_test; 3575 op1 = stack (get_operand (mopnd)); 3576 b1 = addr (rands (op1)) -> symbol.external & addr (rands (op1)) -> symbol.initial > 0; 3577 go to if_join; 3578 3579 action (89): /* (if unless)_main */ 3580 b2 = macro_cond_inst (imac).if_test; 3581 b1 = cs -> subprogram.subprogram_type = main_program; 3582 go to if_join; 3583 3584 action (95): /* (if unless)_needs_descriptors */ 3585 b2 = macro_cond_inst (imac).if_test; 3586 op1 = stack (get_operand (mopnd)); 3587 b1 = addr (rands (op1)) -> symbol.needs_descriptors; 3588 go to if_join; 3589 3590 action (99): /* (if unless)_namelist_used */ 3591 b2 = macro_cond_inst (imac).if_test; 3592 b1 = cs -> subprogram.namelist_used; 3593 go to if_join; 3594 3595 action (118): /* (if unless)_zero */ 3596 b2 = macro_cond_inst (imac).if_test; 3597 b1 = check_zero ((stack (get_operand (mopnd)))); 3598 goto if_join; 3599 3600 action (101): /* if_next_statement */ 3601 b2 = "1"b; 3602 goto next_stmnt_join; 3603 3604 action (102): /* unless_next_statement */ 3605 b2 = "0"b; 3606 3607 next_stmnt_join: 3608 b1 = "0"b; /* target is not next statement */ 3609 op1 = fixed (statement_ptr -> opt_statement.next, 18); 3610 3611 do while (op1 > 0); /* find next executable st */ 3612 if addr (quad (op1)) -> opt_statement.put_in_map 3613 /* an executable statement */ 3614 then do; /* return "1"b if lbl on next st */ 3615 b1 = addr (rands (stack (get_operand (mopnd)))) -> label.statement = op1; 3616 goto if_join; 3617 end; 3618 op1 = fixed (addr (quad (op1)) -> opt_statement.next, 18); 3619 end; 3620 goto if_join; /* no next st, no match */ 3621 3622 action (31): /* if */ 3623 b2 = "1"b; 3624 go to unless_join; 3625 3626 action (32): /* unless */ 3627 b2 = "0"b; 3628 3629 unless_join: 3630 op1 = get_operand (mopnd); 3631 op1 = stack (op1) + bias; 3632 3633 op2 = macro_if_inst (imac).with; 3634 if op2 = 3 3635 then op2 = stack (top) + bias; 3636 3637 relation = fixed (macro_if_inst (imac).relation, 3); 3638 go to comp (relation); 3639 3640 comp (0): 3641 b1 = op1 < op2; 3642 go to if_join; 3643 3644 comp (1): 3645 b1 = op1 > op2; 3646 go to if_join; 3647 3648 comp (2): 3649 b1 = op1 = op2; 3650 go to if_join; 3651 3652 comp (3): 3653 b1 = op1 ^= op2; 3654 go to if_join; 3655 3656 comp (4): 3657 b1 = op1 <= op2; 3658 go to if_join; 3659 3660 comp (5): 3661 b1 = op1 >= op2; 3662 3663 if_join: 3664 if b1 = b2 3665 then do; 3666 imac = left; 3667 go to loop; 3668 end; 3669 3670 go to step; 3671 3672 action (33): /* jump_indexed */ 3673 op1 = get_operand (mopnd); 3674 i = stack (op1) + bias; 3675 3676 if i <= 0 | i > left 3677 then call print_message (402, "jump_indexed"); 3678 else imac = half_array (i); 3679 3680 go to loop; 3681 3682 action (34): /* emit_inst & emit_data */ 3683 if mopnd = 0 /* =0 is emit_data */ 3684 then do imac = imac + 1 to imac + left; 3685 text_word (text_pos) = unspec (machine_instruction (imac)); 3686 text_pos = text_pos + 1; 3687 end; 3688 else do imac = imac + 1 to imac + left; /* ^=0 is emit_inst */ 3689 call check_machine_state (fixed (machine_instruction (imac).op_code, 10), 0); 3690 text_word (text_pos) = unspec (machine_instruction (imac)); 3691 text_pos = text_pos + 1; 3692 end; 3693 go to loop; 3694 3695 action (78): /* assign_entry */ 3696 state_discarded = "0"b; 3697 3698 action (36): /* rel_con */ 3699 call alloc_relcon ((stack (get_operand (mopnd))), text_pos); 3700 goto step; 3701 3702 action (35): /* label */ 3703 call alloc_label ((stack (get_operand (mopnd))), text_pos); 3704 goto step; 3705 3706 action (37): /* set_rel_constant */ 3707 call alloc_relcon ((stack (get_operand (mopnd))), stack (top) + bias); 3708 top = top - 1; 3709 go to step; 3710 3711 action (38): /* add_to_address */ 3712 if left = 0 3713 then do; 3714 if ^analyzing 3715 then instruction (text_pos - 1).offset = instruction (text_pos - 1).offset + stack (top) + bias; 3716 top = top - 1; 3717 end; 3718 3719 else do; 3720 op1 = get_operand (mopnd); 3721 3722 if ^analyzing 3723 then do; 3724 p = addr (rands (stack (op1))); 3725 3726 if p -> label.operand_type ^= rel_constant 3727 then call print_message (411, stack (op1)); 3728 3729 i = p -> label.location + stack (top - 1) + bias; 3730 instruction (i).offset = instruction (i).offset + stack (top) + bias; 3731 end; 3732 3733 top = top - 2; 3734 end; 3735 3736 go to step; 3737 3738 action (39): /* free_temp */ 3739 p = addr (rands (stack (get_operand (mopnd)))); 3740 if analyzing 3741 then p -> temporary.ref_count_copy = 0; 3742 else p -> temporary.ref_count = 0; 3743 call free_temp (p); 3744 go to step; 3745 3746 action (40): /* reserve_regs */ 3747 call reserve_regs ((macro_regs_inst (imac).regs)); 3748 go to step; 3749 3750 action (41): /* load_pr */ 3751 op1 = stack (get_operand (mopnd)); 3752 3753 if assembly_list & addr (rands (op1)) -> node.node_type = symbol_node 3754 then a_name (text_pos) = op1; 3755 3756 call base_man_load_pr (op1, left, "1"b); 3757 go to step; 3758 3759 action (112): /* load_pr_value */ 3760 op1 = stack (get_operand (mopnd)); 3761 3762 if assembly_list & addr (rands (op1)) -> node.node_type = symbol_node 3763 then a_name (text_pos) = op1; 3764 3765 call base_man_load_pr_value (op1, left); 3766 go to step; 3767 3768 simple (49): /* desc_ptr_in_pr3 */ 3769 current_ms.base_regs (which_base (3)).type = 9; 3770 current_ms.base_regs (which_base (3)).used = text_pos; 3771 current_ms.base_regs (which_base (3)).variable = 0; 3772 current_ms.base_regs (which_base (3)).offset = 0; 3773 go to step; 3774 3775 simple (50): /* arg_ptr_in_pr1 */ 3776 current_ms.base_regs (which_base (1)).type = 5; 3777 current_ms.base_regs (which_base (1)).used = text_pos; 3778 current_ms.base_regs (which_base (1)).variable = 0; 3779 current_ms.base_regs (which_base (1)).offset = 0; 3780 go to step; 3781 3782 simple (4): /* free_regs */ 3783 call free_regs; 3784 go to step; 3785 3786 action (44): /* make_addressable */ 3787 action (71): 3788 op1 = get_operand (mopnd); 3789 call m_a (addr (rands (stack (op1)))); 3790 3791 if mop = 71 3792 then do; 3793 op2 = get_operand ((machine_instruction (imac).operand)); 3794 call m_a (addr (rands (stack (op2)))); 3795 end; 3796 3797 go to step; 3798 3799 action (42): /* use_a */ 3800 call use_eaq (0, A, left); 3801 go to step; 3802 3803 action (43): /* use_q */ 3804 call use_eaq (0, Q, left); 3805 go to step; 3806 3807 action (45): /* use_eaq */ 3808 call use_eaq (0, EAQ, left); 3809 go to step; 3810 3811 action (46): /* load */ 3812 op1 = stack (get_operand (mopnd)); 3813 3814 if op1 < 0 /* a count */ 3815 then op1 = create_integer_constant (op1 + bias); 3816 3817 call load (op1, (macro_instruction (imac).eaq_name)); 3818 go to step; 3819 3820 action (47): /* load_top */ 3821 eaq_name = macro_instruction (imac).eaq_name;/* copy in case imac is changed */ 3822 temp = 0; /* swap flag */ 3823 3824 /* If both operands are in the eaq, and we are loading a 3825* logical into the A, get any logical that might be in the 3826* indicators into the A first. This is a kludge, but it 3827* prevents useless stores in some cases. */ 3828 3829 if eaq_name = in_a 3830 then if current_ms.eaq (IND).number > 0 3831 then if addr (rands (stack (top))) -> node.value_in.eaq 3832 then if addr (rands (stack (top - 1))) -> node.value_in.eaq 3833 then call move_logical_to_a (); 3834 3835 /* If both operands are in the eaq, check the eaq names 3836* and swap if the top operand is the wrong name but the 3837* lower one is the right name. */ 3838 3839 if addr (rands (stack (top))) -> node.value_in.eaq 3840 then if addr (rands (stack (top - 1))) -> node.value_in.eaq 3841 then if get_eaq_name (stack (top)) ^= eaq_name 3842 then if get_eaq_name (stack (top - 1)) = eaq_name 3843 then temp = 1; 3844 3845 /* If the top operand is not in the eaq, and the lower one is 3846* or the top operand is constant, swap the operands. */ 3847 3848 if ^addr (rands (stack (top))) -> node.value_in.eaq 3849 then if addr (rands (stack (top - 1))) -> node.value_in.eaq 3850 | addr (rands (stack (top))) -> node.node_type = constant_node 3851 | addr (rands (stack (top))) -> node.node_type = char_constant_node 3852 then temp = 1; 3853 3854 if temp > 0 3855 then do; 3856 k = stack (top - 1); 3857 stack (top - 1) = stack (top); 3858 stack (top) = k; 3859 3860 /* If operands are swapped and a label is given, transfer to that label. */ 3861 3862 if left > 0 3863 then imac = left - 1; 3864 end; 3865 3866 call load ((stack (top)), eaq_name); 3867 3868 go to step; 3869 3870 action (113): /* load_for_test */ 3871 op1 = stack (get_operand (mopnd)); 3872 op2 = macro_instruction (imac).eaq_name; 3873 regno = eaq_name_to_reg (op2); 3874 3875 call load (op1, op2); 3876 3877 /* if indicators are invalid, set them with a compare */ 3878 3879 if current_ms.indicators_valid ^= regno 3880 then do; 3881 call emit_single ((compare_inst (op2)), (zero_for_dt (dt_from_reg (op2)))); 3882 current_ms.indicators_valid = regno; 3883 end; 3884 goto step; 3885 3886 action (111): /* store */ 3887 op1 = stack (get_operand (mopnd)); 3888 call store (op1, (macro_instruction (imac).eaq_name), left); 3889 go to step; 3890 3891 action (48): /* in_reg */ 3892 op1 = stack (get_operand (mopnd)); 3893 call in_reg (op1, (macro_instruction (imac).eaq_name)); 3894 go to step; 3895 3896 action (49): /* refresh_regs */ 3897 call refresh_regs (left); 3898 go to step; 3899 3900 simple (6): /* reset_eaq */ 3901 call reset_eaq (EAQ); 3902 call reset_eaq (IND); 3903 go to step; 3904 3905 simple (7): /* use_ind */ 3906 call use_ind; 3907 go to step; 3908 3909 simple (33): /* ind_to_a */ 3910 call move_logical_to_a (); 3911 go to step; 3912 3913 action (20): /* set_inds_valid */ 3914 eaq_name = macro_instruction (imac).eaq_name; 3915 current_ms.indicators_valid = eaq_name_to_reg (eaq_name); 3916 go to step; 3917 3918 action (51): /* increment */ 3919 op1 = get_operand (mopnd); 3920 stack (op1) = stack (op1) + left; 3921 go to step; 3922 3923 action (52): /* decrement */ 3924 op1 = get_operand (mopnd); 3925 stack (op1) = stack (op1) - left; 3926 go to step; 3927 3928 action (53): /* multiply */ 3929 op1 = get_operand (mopnd); 3930 3931 k = (stack (op1) + bias) * left; /* form product */ 3932 if k >= bias 3933 then call print_message (433, stack (op1), left - bias); 3934 /* product is too large to be count */ 3935 else stack (op1) = k - bias; /* product ok */ 3936 go to step; 3937 3938 action (55): /* push_bif_index */ 3939 op1 = get_operand (mopnd); 3940 i = addr (rands (stack (op1))) -> symbol.char_size - bias; 3941 call push (i); 3942 go to step; 3943 3944 simple (21): /* optimized_subscript */ 3945 call optimized_subscript (quad_ptr); 3946 goto step; 3947 3948 action (64): /* push_array_size */ 3949 op1 = get_operand (mopnd); 3950 p = addr (rands (stack (op1))); 3951 p = addr (rands (p -> symbol.dimension)); 3952 3953 if p -> dimension.variable_array_size 3954 then op1 = p -> dimension.array_size; 3955 else op1 = create_integer_constant ((p -> dimension.array_size)); 3956 3957 call push (op1); 3958 go to step; 3959 3960 action (65): /* print */ 3961 call setup_message_structure; 3962 call print_message_op; 3963 go to step; 3964 3965 action (66): /* error */ 3966 if left ^= 0 3967 then do; 3968 call setup_message_structure; 3969 call print_message_op; 3970 end; 3971 3972 do while (proc_frame.error_label = 0); 3973 cur_frame = proc_frame.prev; 3974 end; 3975 3976 /* In order to prevent errors later on, all operators to which this one is an input are 3977* marked as receiving an ERROR operand. */ 3978 3979 call replace_inputs ((quad_ptr -> operator.output), ERROR); 3980 3981 call pop (proc_frame.base); 3982 3983 p = cur_frame; 3984 3985 call pop_frame; 3986 3987 if ^p -> proc_frame.interpreter_called 3988 then do; 3989 imac = p -> proc_frame.error_label; 3990 go to loop; 3991 end; 3992 3993 else do; 3994 imac = p -> proc_frame.return; 3995 go to p -> proc_frame.interpreter_return; 3996 end; 3997 3998 action (68): /* push_length */ 3999 op1 = get_operand (mopnd); 4000 p = addr (rands (stack (op1))); 4001 call push (get_char_size (p)); 4002 go to step; 4003 4004 action (7): /* emit_eis */ 4005 call emit_eis; 4006 go to step; 4007 4008 simple (13): /* end_unit */ 4009 if top ^= 0 | base > 1 4010 then call print_message (425); 4011 4012 call leave_loop (lp_msp); 4013 4014 if analyzing & n_loops > 1 4015 then do; 4016 call process_loop_end_lists; 4017 call reset_subprogram; 4018 end; 4019 4020 cur_subprogram = cs -> subprogram.next_subprogram; 4021 if cur_subprogram = 0 4022 then return; 4023 4024 call cleanup_loop_state_nodes; 4025 4026 call start_subprogram; 4027 go to step; 4028 4029 action (76): /* make_io_desc */ 4030 result = macro_regs_inst (imac).regs | bit (fixed (stack (top) + bias, 36), 36); 4031 stack (top) = create_constant (int_mode, result); 4032 go to step; 4033 4034 action (77): /* (if unless)_one_word_dt */ 4035 b2 = macro_cond_inst (imac).if_test; 4036 p = addr (rands (stack (get_operand (mopnd)))); 4037 if (p -> node.data_type = int_mode) | (p -> node.data_type = real_mode) 4038 | (p -> node.data_type = typeless_mode) 4039 then b1 = "1"b; 4040 else if (p -> node.data_type = char_mode) 4041 then if (p -> node.node_type = symbol_node) 4042 then b1 = p -> symbol.char_size = 3 & ^p -> symbol.aliasable; 4043 else if (p -> node.node_type = char_constant_node) 4044 then b1 = p -> char_constant.length = 4; 4045 else b1 = "0"b; 4046 else b1 = "0"b; 4047 goto if_join; 4048 4049 simple (14): /* stat */ 4050 cur_statement = fixed (rel (quad_ptr), 18); 4051 statement_ptr = quad_ptr; 4052 4053 if fu ^= statement_ptr -> opt_statement.flow_unit 4054 then do; 4055 4056 /* changing flow_units - refresh the globally assigned registers */ 4057 4058 if fu ^= null 4059 then call refresh_regs (0); 4060 4061 if analyzing & fu ^= null 4062 then call reset_scan (cur_statement, statement_ptr, iquad, fu, cur_lp); 4063 4064 else do; 4065 fu = statement_ptr -> opt_statement.flow_unit; 4066 4067 if fu -> flow_unit.loop ^= cur_lp 4068 then do; 4069 4070 /* changing loops - reset machine states accordingly */ 4071 4072 cur_lp = fu -> flow_unit.loop; 4073 call leave_loop (lp_msp); 4074 call enter_loop (cur_lp, lp_msp); 4075 end; 4076 end; 4077 end; 4078 4079 if statement_ptr -> opt_statement.label ^= 0 4080 then do; 4081 call alloc_label ((statement_ptr -> opt_statement.label), text_pos); 4082 end; 4083 4084 statement_ptr -> opt_statement.location = bit (text_pos, 18); 4085 4086 if generate_profile 4087 then if statement_ptr -> opt_statement.put_in_profile 4088 then call build_profile_entry; 4089 go to step; 4090 4091 simple (15): /* check_parameters */ 4092 /*** Expects: 4093* 4094* count of parameters 4095* param1 4096* param2 4097* . 4098* . 4099* . 4100* paramn ***/ 4101 zarg = base; 4102 n = stack (zarg) + bias; 4103 virtual_origin_count = 0; 4104 4105 /* Perform entry descriptor processing to fill in arguments. */ 4106 /* We will put the node offset to the descriptor into the text section. 4107* gen_entry_defs will later fill in the true text offset from the allocated 4108* nodes. */ 4109 /* NOTE. We depend upon parm_desc_ptrsp being left set to the descriptor 4110* block. This is a relatively safe assumption however. */ 4111 4112 do i = 1 to n; 4113 parm_desc_ptrs.descriptor_relp (i) = make_entry_descriptor ((stack (zarg + i))); 4114 4115 k = fixed (rel (addr (parm_desc_ptrs.descriptor_relp (i)))); 4116 if mod (i, 2) = 0 4117 then reloc (k).left_rel = rc_t; 4118 else reloc (k).right_rel = rc_t; 4119 end; 4120 4121 /* Next store pointers to multi-position parameters, and VLA 4122* parameters. */ 4123 4124 do i = 1 to n; 4125 p = addr (rands (stack (zarg + i))); 4126 4127 if assembly_list & p -> node.node_type = symbol_node 4128 then a_name (text_pos) = stack (zarg + i); 4129 4130 if p -> node.node_type = symbol_node 4131 then if p -> symbol.VLA 4132 then do; 4133 4134 /* Store pointers to Very Large Array parameters in the 4135* VLA pointer blocks. */ 4136 4137 bit3 = base_man_load_any_pr (2, 2 * i, 0); 4138 sym = addr (rands (p -> symbol.dimension)) -> dimension.VLA_base_addressor; 4139 s = addr (rands (sym)); 4140 if VLA_is_256K 4141 then call emit_c_a_var ((store_packed_base (which_base (fixed (bit3, 3)))), s); 4142 else do; /* 255K addressing */ 4143 if assembly_list 4144 then a_name (text_pos) = fixed (rel (p)); 4145 unspec (inst_address) = "0"b; 4146 inst_address.base = bit3; 4147 inst_address.ext_base = "1"b; 4148 call emit_c_a ((epaq), unspec (inst_address)); 4149 call emit_single ((qrl), 18 - bias); 4150 call emit_c_a_var ((stq), s); 4151 call emit_single ((lrl), 54 - bias); 4152 inst_address.base = "000"b; 4153 inst_address.offset = VLA_words_per_seg; 4154 call emit_c_a ((mpy), unspec (inst_address)); 4155 call emit_c_a_var ((asq), s); 4156 if assembly_list 4157 then a_name (text_pos) = fixed (rel (p)); 4158 call emit_c_a ((store_packed_base (which_base (fixed (bit3, 3)))), 4159 c_a ((p -> symbol.address.offset), 6)); 4160 end; 4161 end; 4162 4163 else if p -> symbol.stack_indirect 4164 then do; 4165 bit3 = base_man_load_any_pr (2, 2 * i, 0); 4166 if assembly_list & p -> node.node_type = symbol_node 4167 then a_name (text_pos) = stack (zarg + i); 4168 call emit_c_a ((store_base (which_base (fixed (bit3, 3)))), c_a ((p -> symbol.location), 6)) 4169 ; 4170 end; 4171 end; 4172 4173 /* Next store length of star extent character strings */ 4174 4175 do i = 1 to n; 4176 p = addr (rands (stack (zarg + i))); 4177 4178 if p -> node.node_type = symbol_node 4179 then if p -> symbol.v_length ^= 0 4180 then do; 4181 if assembly_list & p -> node.node_type = symbol_node 4182 then a_name (text_pos) = stack (zarg + i); 4183 call get_param_char_size (p, i); 4184 end; 4185 end; 4186 4187 /* Finally compute bounds, etc. of variable extent arrays */ 4188 4189 do i = 1 to n; 4190 p = addr (rands (stack (zarg + i))); 4191 if p -> node.node_type = symbol_node 4192 then if p -> symbol.dimensioned 4193 then if p -> symbol.variable_extents | p -> symbol.star_extents 4194 then if p -> symbol.allocate 4195 then do; 4196 if assembly_list & p -> node.node_type = symbol_node 4197 then a_name (text_pos) = stack (zarg + i); 4198 call get_param_array_size (p); 4199 end; 4200 end; 4201 4202 /* Last but not least emit code for star extent function allocation. */ 4203 4204 if cs -> subprogram.star_extent_function 4205 then do; 4206 p = addr (rands (cs -> subprogram.first_symbol)); 4207 4208 /* THIS DEPENDS UPON return_value BEING THE FIRST DEFINED SYMBOL IN THE FUNCTION. */ 4209 4210 call emit_single ((load_inst (in_q)), (p -> symbol.v_length)); 4211 call emit_single ((adfx1), 3 - bias); /* adq 3 */ 4212 call emit_single ((qrs), 2 - bias); /* qrs 2 */ 4213 call flush_base (which_base (2)); 4214 call emit_operator_call ((alloc_auto_adj)); 4215 call emit_c_a ((store_base (which_base (2))), c_a ((p -> symbol.location), 6)); 4216 4217 /* If the return_value_param has a descriptor, copy to our descriptor. */ 4218 4219 if addr (rands (stack (zarg + n))) -> symbol.hash_chain ^= 0 & p -> symbol.hash_chain ^= 0 4220 then do; 4221 call emit_single ((load_inst (in_q)), (addr (rands (stack (zarg + n))) -> symbol.hash_chain)); 4222 call emit_single ((store_inst (in_q)), (p -> symbol.hash_chain)); 4223 end; 4224 call reset_eaq (Q); 4225 end; 4226 4227 go to step; 4228 4229 action (80): /* push_char_temp */ 4230 if left < 0 4231 then do; 4232 4233 /* have count */ 4234 4235 left = stack (top) + bias; 4236 top = top - 1; 4237 end; 4238 4239 call push (assign_char_temp (left)); 4240 go to step; 4241 4242 simple (16): /* check_arg_list */ 4243 call check_arg_list; 4244 go to step; 4245 4246 simple (17): /* store_arg_addrs */ 4247 /*** Expects: 4248* 4249* external reference 4250* number of arguments 4251* arg1 4252* arg2 4253* . 4254* . 4255* . 4256* argn 4257* arglist temp ***/ 4258 zarg = base + 1; 4259 n = stack (zarg) + bias; 4260 temp = stack (zarg + n + 1); 4261 4262 do i = 1 to n; /* Modification to reserve base register used for source, so that "m_a" will 4263* not re-use it if > 16K addresses are present in the store. */ 4264 4265 k = get_free_reg (current_ms.base_regs, first_base, last_base, 0, 0); 4266 call base_man_load_pr ((stack (zarg + i)), k, "0"b); 4267 current_ms.base_regs (k).reserved = "1"b; 4268 /* Protect Register */ 4269 4270 if assembly_list & addr (rands (stack (zarg + i))) -> node.node_type = symbol_node 4271 then a_name (text_pos) = stack (zarg + i); 4272 4273 call emit_single_with_inc (store_base (k), temp, 2 * i); 4274 current_ms.base_regs (k).reserved = "0"b; 4275 /* Release base */ 4276 end; 4277 4278 go to step; 4279 4280 action (91): /* (if unless)_constant_addrs */ 4281 b2 = macro_cond_inst (imac).if_test; 4282 zarg = base + 1; 4283 n = stack (zarg) + bias; 4284 b1 = n <= hbound (itp_list, 1); 4285 4286 /* If descriptors must be supplied with this call, we cannot use 4287* an ITP argument list. This is because the constant nodes for 4288* the argument list and the descriptors will not be allocated 4289* until later, and we must know the addresses now. */ 4290 4291 /* If we have a VLA parameter then we MUST make a correct 4292* pointer to it, since we cannot indirect through the stack 4293* or the linkage section through a packed pointer. */ 4294 4295 if addr (rands (stack (base))) -> symbol.needs_descriptors 4296 then b1 = "0"b; 4297 4298 do i = 1 to n while (b1); 4299 p = addr (rands (stack (zarg + i))); 4300 4301 if assembly_list & p -> node.node_type = symbol_node 4302 then a_name (text_pos) = stack (zarg + i); 4303 4304 if p -> node.node_type = symbol_node & p -> symbol.VLA 4305 then b1 = "0"b; /* VLA is non-constant */ 4306 4307 if ^p -> node.is_addressable | ^p -> node.allocated 4308 | p -> node.ext_base & ^(p -> node.base = sp | p -> node.base = lp) 4309 then b1 = "0"b; 4310 end; 4311 4312 go to if_join; 4313 4314 action (93): /* get_quick_label */ 4315 op1 = get_operand (mopnd); 4316 k = stack (op1); 4317 if addr (rands (k)) -> symbol.external 4318 then k = addr (rands (k)) -> symbol.initial; 4319 stack (op1) = addr (rands (k)) -> symbol.initial; 4320 go to step; 4321 4322 simple (18): /* gen_itp_list */ 4323 unspec (arg_list.header) = "0"b; 4324 zarg = base + 1; 4325 n = stack (zarg) + bias; 4326 arg_list.arg_count = 2 * n; 4327 4328 do i = 1 to n; 4329 p = addr (rands (stack (zarg + i))); 4330 call set_itp_addr (p, i); 4331 call drop_count ((stack (zarg + i)), 1); 4332 end; 4333 4334 stack (top) = create_constant_block (addr (arg_list), 2 * n + 2); 4335 go to step; 4336 4337 simple (19): /* make_descriptors */ 4338 if addr (rands (stack (base))) -> symbol.needs_descriptors 4339 then do; 4340 zarg = base + 1; 4341 n = stack (zarg) + bias; 4342 temp = stack (zarg + n + 1); 4343 4344 skip = 2 * n; 4345 if addr (rands (stack (base))) -> symbol.parameter 4346 then skip = skip + 2; 4347 4348 do i = 1 to n; 4349 desc = make_descriptor ((stack (zarg + i))); 4350 /* Modification to reserve base register in case "emit_single_with_inc" causes 4351* long (>16K) addressing and "m_a" requires extra pointer. */ 4352 4353 k = get_free_reg (current_ms.base_regs, first_base, last_base, 0, 0); 4354 4355 if assembly_list & addr (rands (stack (zarg + i))) -> node.node_type = symbol_node 4356 then a_name (text_pos) = stack (zarg + i); 4357 4358 call base_man_load_pr (desc, k, "0"b); 4359 current_ms.base_regs (k).reserved = "1"b; 4360 /* Protect Register */ 4361 call emit_single_with_inc (store_base (k), temp, skip + 2 * i); 4362 current_ms.base_regs (k).reserved = "0"b; 4363 /* Release base */ 4364 end; 4365 4366 end; 4367 4368 go to step; 4369 4370 simple (42): /* free_descriptors */ 4371 do while (desc_temp_chain ^= 0); 4372 p = addr (rands (desc_temp_chain)); 4373 desc_temp_chain = p -> temporary.next; 4374 call free_temp (p); 4375 end; 4376 4377 go to step; 4378 4379 simple (20): /* set_runtime_block_loc */ 4380 addr (rands (stack (base))) -> symbol.hash_chain = text_pos; 4381 go to step; 4382 4383 action (104): /* push_operand */ 4384 next_operand = next_operand + 1; 4385 4386 if next_operand > quad_ptr -> operator.number 4387 then do; 4388 imac = left; 4389 goto loop; 4390 end; 4391 4392 if quad_ptr -> operator.operand (next_operand) = ERROR 4393 then goto operand_is_ERROR; 4394 4395 call push ((quad_ptr -> operator.operand (next_operand))); 4396 goto step; 4397 4398 action (105): /* compare */ 4399 op1 = stack (get_operand (mopnd)); 4400 b1 = check_zero (op1); 4401 eaq_name = macro_instruction (imac).eaq_name; 4402 regno = eaq_name_to_reg (eaq_name); 4403 4404 /* Force temps in any eaq register to storage before eaq state 4405* is destroyed or branch is taken. Do NOT remove this stmt 4406* without checking min/max/dim code */ 4407 4408 call save_eaq_temps (op1, EAQ, 0); 4409 4410 if current_ms.indicators_valid ^= regno | ^b1 4411 then do; 4412 4413 if do_rounding & ^current_ms.rounded 4414 then if (eaq_name = in_eaq) | (eaq_name = in_deaq) 4415 then if (eaq_name = current_ms.eaq (regno).name) | (eaq_name ^= in_deaq) 4416 | (current_ms.eaq (regno).name = 0) 4417 then do; 4418 if current_ms.eaq (regno).name ^= 0 4419 then i = round_inst (current_ms.eaq (regno).name); 4420 else i = round_inst (eaq_name); 4421 call emit_zero (i); 4422 current_ms.rounded = "1"b; 4423 end; 4424 4425 call emit_single ((compare_inst (eaq_name)), op1); 4426 4427 if b1 4428 then current_ms.indicators_valid = regno; 4429 else current_ms.indicators_valid = 0; 4430 4431 end; 4432 4433 goto step; 4434 4435 simple (22): /* sub_index */ 4436 op1 = quad_ptr -> operator.operand (1); /* subscript expression */ 4437 op2 = quad_ptr -> operator.output; 4438 4439 p = addr (rands (op1)); 4440 if ^p -> node.is_addressable 4441 then call m_a (p); 4442 4443 xr = fixed (substr (xr_man_load_any_xr (p), 4, 3), 3); 4444 /* get index reg no */ 4445 call drop_count (op1, 1); 4446 p -> node.value_in.x = "0"b; 4447 4448 call xr_man_update_xr (op2, xr); 4449 goto step; 4450 4451 simple (32): /* drop_all_counts */ 4452 do i = top - quad_ptr -> operator.number + 1 to top; 4453 call drop_count ((stack (i)), 1); 4454 end; 4455 goto step; 4456 4457 action (109): /* flush_ref */ 4458 op1 = stack (get_operand (mopnd)); 4459 call flush_ref (op1); 4460 goto step; 4461 4462 action (110): /* save_state */ 4463 op1 = stack (get_operand (mopnd)); 4464 lbl = addr (rands (op1)); 4465 4466 if left >= 2 4467 then discard = left; 4468 else discard = 0; 4469 4470 if ^lbl -> label.allocated /* i.e., this is a forward reference */ 4471 then if ^addr (quad (lbl -> label.statement)) -> opt_statement.referenced_by_assign 4472 then do; 4473 st = addr (quad (lbl -> label.statement)); 4474 4475 /* If target has an operator list, insure that all temporaries on that list that 4476* are in registers but not in storage are stored. */ 4477 4478 do p = st -> opt_statement.operator_list repeat p -> primary.next while (p ^= null); 4479 4480 k = p -> primary.expression -> operator.output; 4481 if k > 0 /* Might be ERROR or 0 if temp was freed */ 4482 then if addr (rands (k)) -> node.not_in_storage 4483 then if addr (rands (k)) -> temporary.value_in.eaq 4484 then do; /* Value in eaq */ 4485 4486 eaq_name = get_eaq_name (k); 4487 4488 if eaq_name > in_ind 4489 then do; 4490 call move_logical_to_a (); 4491 eaq_name = in_a; 4492 end; 4493 4494 if ^do_rounding | current_ms.rounded 4495 then i = store_no_round_inst (eaq_name); 4496 else i = store_inst (eaq_name); 4497 4498 call emit_temp_store (i, k); 4499 4500 end; 4501 4502 else if addr (rands (k)) -> temporary.value_in.x 4503 then do; /* Value in an index reg. */ 4504 do i = first_index to last_index 4505 while (current_ms.index_regs (i).type ^= 1 4506 | current_ms.index_regs (i).variable ^= k); 4507 end; 4508 call emit_temp_store (sxl0 + i, k); 4509 end; 4510 end; /* loop thru operator list */ 4511 4512 /* Now save the state at the target, but only if target is not backward ref. */ 4513 4514 if ^st -> opt_statement.referenced_backwards 4515 then call save_state (op1); 4516 4517 end; /* code to process target label */ 4518 4519 if discard = 0 4520 then goto step; /* simple(23), discard_state, must follow. */ 4521 4522 simple (23): /* discard_state */ 4523 /* Must immediately follow action(110), save_state */ 4524 call discard_state; 4525 goto step; 4526 4527 action (114): /* set_in_storage */ 4528 op1 = stack (get_operand (mopnd)); 4529 addr (rands (op1)) -> node.not_in_storage = "0"b; 4530 goto step; 4531 4532 action (115): /* bump */ 4533 call bump_count ((stack (get_operand (mopnd))), left); 4534 goto step; 4535 4536 action (116): /* drop */ 4537 call drop_count ((stack (get_operand (mopnd))), left); 4538 goto step; 4539 4540 simple (24): /* push_output */ 4541 op1 = quad_ptr -> operator.output; 4542 if addr (rands (op1)) -> node.node_type = temporary_node 4543 then call assign_address_to_temp (op1, 0); 4544 call push (op1); 4545 goto step; 4546 4547 action (121): /* push_ref_count */ 4548 call push (get_ref_count (addr (rands (stack (get_operand (mopnd))))) - bias); 4549 goto step; 4550 4551 simple (25): /* bump_args */ 4552 do i = base + 2 to base + 2 + stack (base + 1) + bias - 1; 4553 op1 = stack (i); 4554 if op1 > 0 4555 then if addr (rands (op1)) -> node.node_type = temporary_node 4556 then call bump_count (op1, 1); 4557 end; 4558 goto step; 4559 4560 simple (26): /* drop_args */ 4561 do i = base + 2 to base + 2 + stack (base + 1) + bias - 1; 4562 op1 = stack (i); 4563 if op1 > 0 4564 then if addr (rands (op1)) -> node.node_type = temporary_node 4565 then call drop_count (op1, 1); 4566 end; 4567 goto step; 4568 4569 action (123): /* float_power_of_fpbase */ 4570 op1 = get_operand (mopnd); 4571 p = addr (rands (stack (op1))); 4572 4573 /* If we have a floating power of fpbase > -127, then replace operand 4574* with proper exponent for ADE instruction. */ 4575 4576 if p -> node.node_type = constant_node 4577 then if p -> constant.data_type = real_mode | p -> constant.data_type = dp_mode 4578 then do; 4579 unspec (floating_value) = p -> constant.value; 4580 4581 if floating_value.mantissa = mantissa_of_power_of_fpbase & floating_value.exponent > -127 4582 then do; 4583 floating_value.mantissa = "0"b; 4584 floating_value.exponent = floating_value.exponent - 1; 4585 if macro_instruction (imac).eaq_name ^= 0 4586 then floating_value.exponent = -floating_value.exponent; 4587 stack (op1) = create_constant (real_mode, unspec (floating_value)); 4588 imac = left; 4589 go to loop; 4590 end; 4591 end; 4592 4593 go to step; 4594 4595 action (125): /* pad_char_const_to_word */ 4596 op1 = get_operand (mopnd); 4597 4598 if addr (rands (stack (op1))) -> char_constant.length = chars_per_word 4599 then goto step; 4600 4601 else if addr (rands (stack (op1))) -> char_constant.length > chars_per_word 4602 then call print_message (443, chars_per_word - bias, (stack (op1))); 4603 4604 substr (char_temp, 1, chars_per_word) = addr (rands (stack (op1))) -> char_constant.value; 4605 stack (op1) = create_char_constant (substr (char_temp, 1, chars_per_word)); 4606 goto step; 4607 4608 action (126): /* pad_char_const_to_dw */ 4609 op1 = get_operand (mopnd); 4610 4611 if addr (rands (stack (op1))) -> char_constant.length = chars_per_dw 4612 then goto step; 4613 4614 else if addr (rands (stack (op1))) -> char_constant.length > chars_per_dw 4615 then call print_message (443, chars_per_dw - bias, (stack (op1))); 4616 4617 substr (char_temp, 1, chars_per_dw) = addr (rands (stack (op1))) -> char_constant.value; 4618 stack (op1) = create_char_constant (substr (char_temp, 1, chars_per_dw)); 4619 goto step; 4620 4621 action (127): /* power_of_two */ 4622 op1 = get_operand (mopnd); 4623 p = addr (rands (stack (op1))); 4624 4625 /* If power of two then replace operand with power of two and jump to address. */ 4626 4627 if p -> node.node_type ^= constant_node 4628 then goto step; 4629 4630 if p -> constant.data_type ^= int_mode 4631 then goto step; 4632 4633 if addr (p -> constant.value) -> int_image <= 0 4634 then goto step; 4635 4636 i = index (p -> constant.value, "1"b); /* find high-order bit */ 4637 4638 if substr (p -> constant.value, i + 1, 36 - i) = "0"b 4639 /* all other bits are zero */ 4640 then do; 4641 stack (op1) = (36 - i) - bias; /* Replace power of two with count. */ 4642 4643 imac = left; /* set transfer location. */ 4644 goto loop; 4645 end; 4646 goto step; 4647 4648 simple (29): /* set_rounded */ 4649 current_ms.rounded = "1"b; 4650 go to step; 4651 4652 action (108): /* round */ 4653 if do_rounding & ^current_ms.rounded 4654 then do; 4655 eaq_name = macro_instruction (imac).eaq_name; 4656 call emit_zero ((round_inst (eaq_name))); 4657 current_ms.rounded = "1"b; 4658 current_ms.indicators_valid = eaq_name_to_reg (eaq_name); 4659 end; 4660 4661 go to step; 4662 4663 simple (30): /* load_xreg */ 4664 next_lp = fu -> flow_unit.successors -> edge.to.value -> flow_unit.loop; 4665 4666 /* This assigns an index register to stack(base) over the loop 4667* nest following this flow_unit. We attempt to avoid x6 because 4668* that register is modified by I/O operations. Note 4669* that stack(top) is actually loaded. */ 4670 4671 if ^next_lp -> loop.all_xrs_globally_assigned 4672 then do; 4673 b1 = current_ms.index_regs (6).reserved; 4674 if ^current_ms.index_regs (6).global 4675 then current_ms.index_regs (6).reserved = "1"b; 4676 end; 4677 4678 if analyzing | stack (base) = stack (top) 4679 then do; 4680 p = addr (rands (stack (base))); 4681 bit6 = xr_man_load_any_xr (p); 4682 regno = fixed (substr (bit6, 4, 3), 3); 4683 4684 /* Deal with strange case of induction var busy_on_exit 4685* from loop, but which might not be initialized on entry 4686* to the loop. */ 4687 4688 if p -> node.node_type = symbol_node 4689 then do; 4690 i = p -> symbol.coordinate; 4691 if substr (next_lp -> loop.induction_var -> bits, i, 1) 4692 & substr (next_lp -> loop.busy_on_exit -> bits, i, 1) 4693 then if ^definitely_initialized (i, fu) 4694 then do; 4695 call emit_temp_store (stz, (stack (base))); 4696 if substr (fu -> flow_unit.busy_on_exit -> bits, i, 1) 4697 then call emit_temp_store (sxl0 + regno, (stack (base))); 4698 end; 4699 end; 4700 end; 4701 4702 else do; 4703 call flush_ref ((stack (base))); 4704 regno = get_free_reg (current_ms.index_regs, first_index, last_index, 0, 0); 4705 call xr_man_load_xr (addr (rands (stack (top))), regno, (stack (base))); 4706 if next_lp -> loop.erases.xr (regno) 4707 then call emit_temp_store (sxl0 + regno, (stack (base))); 4708 end; 4709 4710 if ^next_lp -> loop.all_xrs_globally_assigned 4711 then current_ms.index_regs (6).reserved = b1; 4712 4713 call drop_count ((stack (top)), 1); 4714 call drop_count ((stack (base)), 1); 4715 4716 current_ms.index_regs (regno).reserved = "1"b; 4717 4718 if ^analyzing 4719 then call assign_register (next_lp, INDEX, regno, 1, (stack (base)), 0); 4720 go to step; 4721 4722 simple (31): /* load_preg */ 4723 next_lp = fu -> flow_unit.successors -> edge.to.value -> flow_unit.loop; 4724 p = addr (rands (stack (top))); 4725 4726 /* This assigns a base register to stack(top) over the loop nest 4727* following this flow_unit. */ 4728 4729 base_man_args.code = p -> pointer.code; 4730 base_man_args.variable = p -> pointer.variable; 4731 base_man_args.offset = p -> pointer.offset; 4732 4733 if string (next_lp -> loop.avoid_pr) 4734 then call avoid_prs (string (next_lp -> loop.avoid_pr)); 4735 4736 bit3 = base_man_dispatch (base_man_args.code, base_man_args.variable, base_man_args.offset); 4737 regno = which_base (fixed (bit3, 3)); 4738 4739 if next_lp -> loop.avoid_pr (regno) 4740 then do; 4741 4742 /* This register was supposed to have been avoided. 4743* Erase and try again!! */ 4744 4745 call flush_base (regno); 4746 current_ms.base_regs (regno).type = -1; 4747 bit3 = base_man_dispatch (base_man_args.code, base_man_args.variable, base_man_args.offset); 4748 regno = which_base (fixed (bit3, 3)); 4749 end; 4750 4751 if string (next_lp -> loop.avoid_pr) 4752 then call restore_pr_locks; 4753 4754 /* Fix for bug 358. Correctly lock a base reserved by a 'load_preg'. 4755* by not doing this the count of ptr_data.max_locked, and ptr_data.locked is 4756* too low and we have a good chance of running out of registers. */ 4757 4758 call lock_base (regno); 4759 4760 if ^analyzing 4761 then call assign_register (next_lp, BASE, regno, base_man_args.code, base_man_args.variable, 4762 base_man_args.offset); 4763 go to step; 4764 4765 simple (34): /* assign_index */ 4766 call assign_index ((stack (base)), (stack (base + 1))); 4767 go to step; 4768 4769 simple (35): /* compare_index */ 4770 call compare_index ((stack (base)), (stack (base + 1))); 4771 go to step; 4772 4773 simple (36): /* test_index */ 4774 call compare_index ((stack (base)), builtins (0)); 4775 go to step; 4776 4777 simple (37): /* increment_index */ 4778 call increment_index ((stack (base + 1)), (stack (base)), +1); 4779 go to step; 4780 4781 simple (38): /* decrement_index */ 4782 call increment_index ((stack (base + 1)), (stack (base)), -1); 4783 go to step; 4784 4785 simple (40): /* refresh_regs_if_next_is_jump */ 4786 /*** This code attempts to eliminate flushing of indicators by 4787* refresh_regs before a conditional jump at the end of a flow_unit. ***/ 4788 if lp_msp ^= null 4789 then if addr (quad (iquad)) -> operator.operand (1) = quad_ptr -> operator.output 4790 then if addr (quad (iquad)) -> operator.op_code = jump_true_op 4791 | addr (quad (iquad)) -> operator.op_code = jump_false_op 4792 then call refresh_regs (0); 4793 4794 go to step; 4795 4796 simple (41): /* note_eligible_ind_var_use */ 4797 /*** If an eligible induction variable appears in an incrementing 4798* or comparison context and index registers are not erased in this 4799* loop, then the use should be recorded in the global database. ***/ 4800 if analyzing 4801 then if substr (string (cur_lp -> loop.erases.xr), 3) ^= "111111"b 4802 then do i = base by 1 while (i <= top); 4803 if stack (i) > 0 4804 then do; 4805 p = addr (rands (stack (i))); 4806 if is_induction_var (p) 4807 then if eligible (p) 4808 then call add_global_index (p); 4809 end; 4810 end; 4811 4812 go to step; 4813 4814 simple (43): /* force_ql */ 4815 if ^analyzing 4816 then instruction (text_pos - 1).tag = QL_mod; 4817 4818 go to step; 4819 4820 simple (44): /* int_to_char1 */ 4821 p = addr (rands (stack (top))); 4822 if p -> node.node_type = constant_node & p -> node.data_type = int_mode 4823 then do; 4824 char1 = byte (addr (p -> constant.value) -> int_image); 4825 call push (create_char_constant (char1)); 4826 end; 4827 else call print_message (462); 4828 4829 go to step; 4830 4831 simple (45): /* char1_to_int */ 4832 p = addr (rands (stack (top))); 4833 if p -> node.node_type = char_constant_node 4834 then do; 4835 temp = rank (substr (p -> char_constant.value, 1, 1)); 4836 call push (create_integer_constant ((temp))); 4837 end; 4838 else call print_message (463); 4839 4840 go to step; 4841 4842 action (59): /* set_next_operand */ 4843 next_operand = left - 1; 4844 go to step; 4845 4846 4847 action (57): /* start_cat */ 4848 call start_cat (b1); 4849 if b1 4850 then do; /* Skip first mlr */ 4851 imac = left; 4852 go to loop; 4853 end; 4854 else go to step; 4855 4856 simple (46): /* continue_cat */ 4857 call continue_cat (); 4858 go to step; 4859 4860 simple (47): /* finish_cat */ 4861 call finish_cat (); 4862 go to step; 4863 4864 action (58): /* shorten_stack */ 4865 if current_ms.stack_extended 4866 then do; 4867 call reserve_regs (shorten_stack_mask); 4868 if left > 0 /* Protect indicators? */ 4869 then call emit_operator_call (shorten_stack_protect_ind); 4870 else do; 4871 call use_ind (); 4872 call emit_operator_call (shorten_stack); 4873 end; 4874 4875 current_ms.stack_extended = "0"b; 4876 current_ms.last_dynamic_temp = 0; 4877 4878 call free_regs (); 4879 end; 4880 4881 go to step; 4882 4883 simple (27): /* push_operand_count */ 4884 call push (quad_ptr -> operator.number - bias); 4885 go to step; 4886 4887 action (60): /* (if unless)_ansi77 */ 4888 b2 = macro_cond_inst (imac).if_test; 4889 b1 = cs -> subprogram.options.ansi_77; 4890 go to if_join; 4891 4892 simple (48): /* set_needs_descriptors */ 4893 addr (rands (stack (base))) -> symbol.needs_descriptors = "1"b; 4894 go to step; 4895 4896 action (69): /* (if unless)_variable_arglist */ 4897 b2 = macro_cond_inst (imac).if_test; 4898 op1 = stack (get_operand (mopnd)); 4899 b1 = addr (rands (op1)) -> symbol.variable_arglist; 4900 go to if_join; 4901 4902 action (74): /* (if unless)_char_star_function */ 4903 b2 = macro_cond_inst (imac).if_test; 4904 b1 = cs -> subprogram.star_extent_function; 4905 go to if_join; 4906 4907 action (75): /* (if unless)_check_multiply */ 4908 b2 = macro_cond_inst (imac).if_test; 4909 b1 = cs -> subprogram.options.check_multiply; 4910 go to if_join; 4911 4912 4913 action (79): /* (if unless)_storage_created */ 4914 b2 = macro_cond_inst (imac).if_test; 4915 if Area_create_first >= 0 4916 then b1 = "1"b; 4917 else b1 = "0"b; 4918 go to if_join; 4919 4920 action (88): /* (if unless)_VLA */ 4921 b2 = macro_cond_inst (imac).if_test; 4922 op1 = stack (get_operand (mopnd)); 4923 4924 /* Only VLA if it is a symbol, which is VLA. */ 4925 4926 if addr (rands (op1)) -> node.node_type = symbol_node 4927 then b1 = addr (rands (op1)) -> symbol.VLA; 4928 else b1 = "0"b; 4929 go to if_join; 4930 4931 action (90): /* (if unless)_cleanup */ 4932 b2 = macro_cond_inst (imac).if_test; 4933 b1 = alloc_auto_cleanup; 4934 go to if_join; 4935 4936 4937 simple (52): /* emit_cleanup_args */ 4938 text_halfs (text_pos).left = cleanup_body_address; 4939 if assembly_list 4940 then a_name (text_pos) = -1; /* tell listing generator this is not an inst */ 4941 text_pos = text_pos + 1; 4942 go to step; 4943 4944 4945 simple (53): /* emit_storage_args */ 4946 if Area_create_first < 0 /* See if storage */ 4947 then do; 4948 text_halfs (text_pos).left = fixed ("777777"b3, 18); 4949 reloc (text_pos).left_rel = rc_a; /* leave absolute */ 4950 end; 4951 else do; 4952 text_halfs (text_pos).left = Area_create_first; 4953 reloc (text_pos).left_rel = rc_t; /* relocate in text */ 4954 end; 4955 4956 if Area_init_first < 0 /* See if initialization */ 4957 then do; 4958 text_halfs (text_pos).right = fixed ("777777"b3, 18); 4959 reloc (text_pos).right_rel = rc_a; /* leave absolute */ 4960 end; 4961 else do; 4962 text_halfs (text_pos).right = Area_init_first; 4963 reloc (text_pos).right_rel = rc_t; /* relocate in text */ 4964 end; 4965 4966 if assembly_list 4967 then a_name (text_pos) = -1; /* list in octal */ 4968 4969 text_pos = text_pos + 1; 4970 goto step; 4971 4972 4973 simple (54): /* emit_profile_entry */ 4974 if ^(generate_profile & generate_long_profile) 4975 then goto step; 4976 4977 call emit_profile_dummy; 4978 call emit_profile_dummy; 4979 4980 call emit_profile_control; 4981 call emit_profile_control; 4982 4983 call emit_profile_dummy; 4984 4985 goto step; 4986 4987 4988 emit_profile_dummy: 4989 proc; 4990 4991 /* emit a long_profile reference to long_profile_header.dummy */ 4992 4993 call emit_operator_call (long_profile); 4994 text_halfs (text_pos).left = profile_start; 4995 reloc (text_pos).left_rel = rc_is18; 4996 4997 /* emit relative offset from long_profile_header to dummy entry */ 4998 4999 text_halfs (text_pos).right = 5; /* dummy offset */ 5000 reloc (text_pos).right_rel = rc_a; 5001 text_pos = text_pos + 1; 5002 return; 5003 end emit_profile_dummy; 5004 5005 5006 emit_profile_control: 5007 proc; 5008 5009 /* emit a long_profile reference to long_profile_header.control */ 5010 5011 call emit_operator_call (long_profile); 5012 text_halfs (text_pos).left = profile_start; 5013 reloc (text_pos).left_rel = rc_is18; 5014 5015 /* emit relative offset from long_profile_header to control entry */ 5016 5017 text_halfs (text_pos).right = 9; /* control offset */ 5018 reloc (text_pos).right_rel = rc_a; 5019 text_pos = text_pos + 1; 5020 return; 5021 end emit_profile_control; 5022 5023 simple (56): /* emit_entry_defs */ 5024 /*** Expects: 5025* 5026* entry label 5027* count of parameters 5028* 5029* 5030* Make pointer to descriptor area we will build later. 5031* 5032* We will allocate space to put the node offset to the 5033* descriptor in the text section. This will later be filled 5034* by 'check_parameters' to hold the index of the constant 5035* node, then gen_entry_defs will later fill in the true text 5036* offset from the allocated nodes. 5037* 5038* This code is split into the three sections, this, 5039* check_parameters, and gen_entry_defs, since at this point 5040* we need to reserve space, but have not yet seen the quads 5041* or polish defining the parameters. At check parameters we 5042* put in the node offset to the descriptor, since it may not 5043* have been allocated, and forward refs only relocate the 5044* left half of an instruction. Finally at gen_entry_defs time 5045* we convert the node index to a text offset because all text 5046* allocations have been made at that time. ***/ 5047 zarg = base + 2; 5048 n = stack (base + 1) + bias; 5049 5050 parm_desc_ptrsp = addr (text_word (text_pos)); 5051 parm_desc_ptrs.n_args = n; 5052 k = text_pos; 5053 5054 /* Skip allocated area, and setup descr_relp_offset */ 5055 5056 text_pos = text_pos + divide (n, 2, 18) + 1; 5057 text_halfs (text_pos).left = k; 5058 text_halfs (text_pos).right = 0; 5059 5060 reloc (text_pos).left_rel = rc_t; 5061 reloc (text_pos).right_rel = rc_a; 5062 text_pos = text_pos + 1; 5063 go to step; 5064 5065 simple (57): /* rhs_fld */ 5066 call rhs_fld; 5067 goto step; 5068 5069 simple (58): /* lhs_fld */ 5070 call lhs_fld; 5071 goto step; 5072 5073 action (92): /* (if unless)_hfp */ 5074 b2 = macro_cond_inst (imac).if_test; 5075 b1 = cs -> subprogram.options.hfp; 5076 goto if_join; 5077 5078 /* These macro opcodes are unused, or (if named) are used only by the 5079* non-optimizing code generator. */ 5080 5081 simple (5): /* reset_regs */ 5082 simple (8): /* start_subscript */ 5083 simple (9): /* next_subscript */ 5084 simple (10): /* finish_suscript */ 5085 simple (11): /* subscript_error */ 5086 simple (12): /* s_func_finish */ 5087 simple (28): /* skip_data */ 5088 simple (39): /* make_substring */ 5089 simple (51): 5090 call print_message (436, left - bias); 5091 goto step; 5092 5093 action (5): /* push_variable */ 5094 action (18): /* exit */ 5095 action (50): /* push_sf_arg_count */ 5096 action (56): /* (if unless)_saving_stack_extent */ 5097 action (61): /* s_func_label */ 5098 action (62): /* push_s_func_label */ 5099 action (63): /* push_s_func_var */ 5100 action (94): 5101 action (96): 5102 action (97): 5103 action (98): 5104 action (100): 5105 action (103): 5106 action (106): 5107 action (107): 5108 action (117): 5109 action (119): 5110 action (120): 5111 action (122): 5112 call print_message (436, mop - bias); 5113 goto step; 5114 5115 /* THESE SHOULD NOT EXECUTE */ 5116 action (0): /* undefined */ 5117 action (12): /* func */ 5118 action (13): /* proc */ 5119 action (67): /* used by rest_of_error */ 5120 call print_message (413); 5121 5122 step: 5123 end; 5124 5125 /**** STACK FRAME MANIPULATION ****/ 5126 5127 push: 5128 procedure (i); 5129 5130 /* Pushes an item onto the operand stack */ 5131 5132 dcl i fixed binary (18); 5133 5134 top = top + 1; 5135 5136 if top > hbound (stack, 1) 5137 then do; 5138 call print_message (407, "operand stack", hbound (stack, 1) - bias); 5139 return; 5140 end; 5141 5142 stack (top) = i; 5143 5144 end push; 5145 5146 copy: 5147 procedure (opnd); 5148 5149 /* Copies an operand onto the top of the stack */ 5150 5151 dcl (opnd, op) fixed binary (18); 5152 5153 op = opnd; 5154 5155 call push (op); 5156 5157 end copy; 5158 5159 pop: 5160 procedure (thru); 5161 5162 /* Pops the stack through thru -- top becomes thru - 1 */ 5163 5164 dcl thru fixed binary (18); /* pop through thru */ 5165 5166 top = thru - 1; 5167 5168 end pop; 5169 5170 pop_frame: 5171 procedure (); 5172 5173 /* Pops a procedure frame */ 5174 5175 cur_frame = cur_frame -> proc_frame.prev; 5176 base = cur_frame -> proc_frame.base; 5177 5178 end pop_frame; 5179 5180 get_operand: 5181 procedure (opnd) returns (fixed binary (18)); 5182 5183 /* Takes an operand number as specified in a macro and returns 5184* the corresponding operand stacksubscript. */ 5185 5186 dcl opnd fixed binary (18); /* Operand number specified in macro */ 5187 5188 dcl i fixed binary (18); 5189 5190 if opnd < 0 5191 then return (top + opnd + 1); /* opn */ 5192 else if opnd > 0 5193 then return (base + opnd - 1); /* argn */ 5194 else do; 5195 5196 /* opv */ 5197 5198 i = stack (top) + bias; 5199 top = top - 1; 5200 return (top - i + 1); 5201 end; 5202 5203 end get_operand; 5204 5205 interpreter_proc: 5206 procedure (mac_num, ret_lab); 5207 5208 /* Calls an interpreter macro procedure. ret_lab must 5209* be set to the label of the stmt immediately following 5210* the call to interpreter_proc. 5211* 5212* Note that this scheme is really an attempt to escape the 5213* necessity for recursion in invoking interpreter macro 5214* procedures. To be truly safe, this should have recursively 5215* invoked the entire interpreter. For this scheme to work, 5216* all procedures between the caller and the interpreter MUST 5217* be quick, and none of them (including the caller) must be 5218* invoked during the processing of the interpreter macro 5219* procedure. This is necessary to ensure that no local 5220* variables are destroyed. Obviously a procedure is safe if 5221* its last statement results in a call to interpreter_proc; 5222* the interesting cases arise when some other statement in 5223* a procedure directly or indirectly invokes interpreter_proc. 5224* 5225* Of course, this is illegal PL/I. */ 5226 5227 dcl mac_num fixed binary (18), /* Macro number of interpreter procedure */ 5228 ret_lab label local; /* Label to return to */ 5229 5230 dcl macro_proc fixed binary (18); 5231 5232 macro_proc = fort_opt_macros_$interpreter_macros (mac_num).entry; 5233 5234 call setup_call (macro_proc, imac, imac, 0); 5235 5236 proc_frame.interpreter_called = "1"b; 5237 proc_frame.interpreter_return = ret_lab; 5238 5239 imac = macro_proc; 5240 go to step; 5241 5242 end interpreter_proc; 5243 5244 setup_call: 5245 procedure (macro_proc, return, error_exit, nb); 5246 5247 /* Pushes a new procedure frame and sets it up for a call */ 5248 5249 dcl macro_proc fixed binary (18), /* Procedure being called */ 5250 return fixed binary (18), /* Location from which the call is being made */ 5251 error_exit fixed binary (18), /* Location to jump to if errors occur */ 5252 nb fixed binary (18); /* Presupplied next_base if ^= 0 */ 5253 5254 dcl (mac_proc, next_base) fixed binary (18); 5255 5256 mac_proc = macro_proc; 5257 5258 if nb = 0 5259 then next_base = get_nextbase (mac_proc, not_given); 5260 else next_base = nb; 5261 5262 /* get next procedure frame */ 5263 5264 if cur_frame -> proc_frame.next ^= null 5265 then cur_frame = cur_frame -> proc_frame.next; 5266 else cur_frame = create_proc_frame (); 5267 5268 /* initialize next procedure frame */ 5269 5270 string (proc_frame.flags) = "0"b; 5271 5272 if fixed (macro_instruction (mac_proc).op_code, 7) = function 5273 then proc_frame.func = "1"b; 5274 5275 proc_frame.return = return; 5276 proc_frame.error_label = error_exit; 5277 base, proc_frame.base = next_base; 5278 proc_frame.nshort = 0; 5279 5280 end setup_call; 5281 5282 create_proc_frame: 5283 procedure () returns (pointer); 5284 5285 /* Allocates a procedure frame in the operand region */ 5286 5287 dcl p pointer; 5288 5289 if mod (next_free_operand, 2) ^= 0 5290 then do; 5291 rands (next_free_operand) = 0; /* for debugging */ 5292 next_free_operand = next_free_operand + 1; 5293 end; 5294 5295 5296 p = addr (rands (next_free_operand)); 5297 next_free_operand = next_free_operand + size (proc_frame); 5298 5299 if next_free_operand >= operand_max_len 5300 then do; 5301 call print_message (407, "operand region", char (operand_max_len)); 5302 /* FATAL */ 5303 return (null); /* should never be executed */ 5304 end; 5305 5306 if cur_frame ^= null 5307 then cur_frame -> proc_frame.next = p; 5308 5309 unspec (p -> proc_frame) = "0"b; 5310 p -> proc_frame.prev = cur_frame; 5311 p -> proc_frame.next = null; 5312 return (p); 5313 5314 end create_proc_frame; 5315 5316 get_nextbase: 5317 procedure (macro_proc, args) returns (fixed binary (18)); 5318 5319 /* Calculates base of new stack frame */ 5320 5321 dcl macro_proc fixed binary (18); /* Proc being called */ 5322 5323 dcl (args, nargs) fixed binary (18); 5324 5325 nargs = args; 5326 5327 if nargs = not_given 5328 then nargs = macro_dt_inst (macro_proc).data_type; 5329 5330 if nargs = variable_count 5331 then if mop = 17 /* scan macro */ 5332 then nargs = quad_ptr -> operator.number; 5333 else call print_message (437); /* must be scan frame */ 5334 else if mop = 17 /* scan macro */ 5335 then if nargs > quad_ptr -> operator.number /* for DEBUGGING */ 5336 then call print_message (438, nargs - bias, quad_ptr -> operator.number - bias); 5337 /* for DEBUGGING */ 5338 return (top - nargs + 1); 5339 5340 end get_nextbase; 5341 5342 /**** TEMPORARY MANAGEMENT ****/ 5343 5344 assign_temp: 5345 procedure (data_type) returns (fixed binary (18)); 5346 5347 /* Assigns a temporary of a specific data type */ 5348 5349 dcl data_type fixed binary (4); 5350 5351 dcl (clength, dt, size, temp) fixed binary (18); 5352 5353 dt = data_type; 5354 size = data_type_size (dt); 5355 go to join; 5356 5357 5358 assign_char_temp: 5359 entry (char_length) returns (fixed binary (18)); 5360 5361 /* Assigns a character temporary */ 5362 5363 dcl char_length fixed binary (18); 5364 5365 dt = char_mode; 5366 clength = char_length; 5367 size = divide (clength + chars_per_word - 1, chars_per_word, 17, 0); 5368 go to join; 5369 5370 5371 assign_block: 5372 entry (block_size) returns (fixed binary (18)); 5373 5374 /* Assigns a doubleword aligned block */ 5375 5376 dcl block_size fixed binary (18); 5377 5378 size = block_size; 5379 size = size + mod (size, 2); 5380 dt = 0; 5381 5382 join: 5383 temp = get_temp (size); 5384 addr (rands (temp)) -> temporary.data_type = dt; 5385 if analyzing 5386 then addr (rands (temp)) -> temporary.ref_count_copy = 1; 5387 else addr (rands (temp)) -> temporary.ref_count = 1; 5388 addr (rands (temp)) -> temporary.dont_update = "0"b; 5389 addr (rands (temp)) -> temporary.used_as_subscript = "0"b; 5390 addr (rands (temp)) -> temporary.units = word_units; 5391 5392 if dt = char_mode 5393 then do; 5394 addr (rands (temp)) -> temporary.length = clength; 5395 if cs -> subprogram.options.ansi_77 5396 then addr (rands (temp)) -> temporary.units = char_units; 5397 end; 5398 5399 return (temp); 5400 5401 get_temp: 5402 procedure (amount) returns (fixed binary (18)); 5403 5404 /* Finds a free temporary of the desired size */ 5405 5406 dcl (amt, amount, i, prev, temp) fixed binary (18); 5407 5408 amt = amount; 5409 5410 if amt <= 2 5411 then do; 5412 i = amt; 5413 temp = free_temps (i); 5414 5415 if temp ^= 0 5416 then do; 5417 free_temps (i) = addr (rands (temp)) -> temporary.next; 5418 return (temp); 5419 end; 5420 end; 5421 5422 else do; 5423 i = 3; 5424 prev = 0; 5425 temp = free_temps (3); 5426 5427 do while (temp ^= 0); 5428 5429 if addr (rands (temp)) -> temporary.size >= amt 5430 then do; 5431 if prev = 0 5432 then free_temps (3) = addr (rands (temp)) -> temporary.next; 5433 else addr (rands (prev)) -> temporary.next = addr (rands (temp)) -> temporary.next; 5434 return (temp); 5435 end; 5436 5437 prev = temp; 5438 temp = addr (rands (temp)) -> temporary.next; 5439 end; 5440 end; 5441 5442 if i > 1 5443 then if mod (last_auto_loc, 2) ^= 0 5444 then do; 5445 5446 /* force doubleword alignment */ 5447 5448 temp = create_temp (1); 5449 addr (rands (temp)) -> temporary.next = free_temps (1); 5450 free_temps (1) = temp; 5451 end; 5452 5453 return (create_temp (amt)); 5454 5455 end get_temp; 5456 5457 end assign_temp; 5458 5459 get_temp_node: 5460 procedure () returns (fixed binary (18)); 5461 5462 /* Gets a temp node off the free chain or allocates a new one. */ 5463 5464 dcl size builtin; 5465 dcl temp fixed binary (18); 5466 5467 if next_free_temp = 0 5468 then temp = create_node (temporary_node, size (temporary)); 5469 else do; 5470 temp = next_free_temp; 5471 next_free_temp = addr (rands (temp)) -> temporary.next; 5472 5473 unspec (addr (rands (temp)) -> temporary) = "0"b; 5474 addr (rands (temp)) -> temporary.node_type = temporary_node; 5475 end; 5476 5477 return (temp); 5478 5479 end get_temp_node; 5480 5481 create_temp: 5482 procedure (amount) returns (fixed binary (18)); 5483 5484 /* Creates a new temporary, possibly reusing a discarded 5485* temporary node. */ 5486 5487 dcl (amount, op_type, temp) fixed binary (18); 5488 dcl amt fixed binary (18); 5489 dcl loc fixed binary (18); 5490 dcl p pointer; 5491 5492 temp = get_temp_node (); 5493 op_type = temp_type; 5494 amt = amount; 5495 loc = last_auto_loc; 5496 5497 if loc + amt > max_stack_size 5498 then call print_message (414, "in making a temporary the stack frame", max_stack_size - bias); 5499 else last_auto_loc = loc + amt; 5500 5501 p = addr (rands (temp)); 5502 5503 p -> temporary.operand_type = op_type; 5504 string (p -> temporary.addressing_bits), string (p -> temporary.bits) = "0"b; 5505 5506 p -> temporary.is_addressable, p -> temporary.allocate, p -> temporary.allocated = "1"b; 5507 5508 unspec (p -> temporary.address) = ext_base_on; 5509 p -> temporary.base = sp; 5510 5511 if op_type = temp_type 5512 then do; 5513 p -> temporary.size = amt; 5514 p -> temporary.not_in_storage = "1"b; 5515 end; 5516 5517 p -> temporary.next = 0; 5518 5519 p -> temporary.units = word_units; 5520 5521 call set_address_offset (p, loc, amt, word_units); 5522 5523 return (temp); 5524 5525 end create_temp; 5526 5527 assign_address_to_temp: 5528 procedure (a_temp, a_new); 5529 5530 /* Assigns address to temp from second arg, or 5531* insures that first arg has an address. In the 5532* latter case, the second arg must be zero. */ 5533 5534 dcl a_temp fixed binary (18); /* Temp that may need an address */ 5535 dcl a_new fixed binary (18); /* Temp that provides an address */ 5536 5537 dcl (temp, new) fixed binary (18); 5538 dcl (temp_pt, new_pt) pointer; 5539 5540 temp = a_temp; 5541 temp_pt = addr (rands (temp)); 5542 new = a_new; 5543 new_pt = addr (rands (new)); 5544 5545 /* Make sure we are not processing temp with ref_count of 0 */ 5546 5547 if get_ref_count (temp_pt) = 0 5548 then do; 5549 if ^analyzing 5550 then call print_message (454, temp); 5551 return; 5552 end; 5553 5554 /* if temp has address, return; in this case, arg 2 must be zero */ 5555 5556 if unspec (temp_pt -> temporary.address) ^= "0"b 5557 then do; 5558 if new ^= 0 & ^analyzing 5559 then do; 5560 call print_message (442); 5561 call free_temp (new_pt); 5562 end; 5563 return; 5564 end; 5565 5566 /* get address if not provided by caller */ 5567 5568 if new = 0 5569 then do; 5570 if temp_pt -> temporary.data_type = char_mode 5571 then new = assign_char_temp ((temp_pt -> temporary.length)); 5572 else new = assign_temp ((temp_pt -> temporary.data_type)); 5573 new_pt = addr (rands (new)); 5574 end; 5575 5576 /* copy address over to target temp */ 5577 5578 string (temp_pt -> temporary.addressing_bits) = 5579 string (temp_pt -> temporary.addressing_bits) | string (new_pt -> temporary.addressing_bits); 5580 if new_pt -> temporary.stack_indirect /* Dynamic temp */ 5581 then temp_pt -> temporary.addr_hold = new_pt -> temporary.addr_hold; 5582 5583 temp_pt -> temporary.address = new_pt -> temporary.address; 5584 5585 temp_pt -> temporary.location = new_pt -> temporary.location; 5586 temp_pt -> temporary.dont_update = "0"b; /* because analysis may have left this on */ 5587 5588 /* copy size over to target temp */ 5589 5590 temp_pt -> temporary.size = new_pt -> temporary.size; 5591 if temp_pt -> temporary.data_type = char_mode 5592 then do; 5593 temp_pt -> temporary.variable_length = new_pt -> temporary.variable_length; 5594 temp_pt -> temporary.length = new_pt -> temporary.length; 5595 new_pt -> temporary.variable_length = "0"b; 5596 new_pt -> temporary.length = 0; 5597 end; 5598 5599 /* take address from source temp, then free it */ 5600 5601 unspec (new_pt -> temporary.address) = "0"b; 5602 call free_temp (new_pt); 5603 5604 end assign_address_to_temp; 5605 5606 free_temp: 5607 procedure (temp_ptr); 5608 5609 /* Procedure to free a temporary. If the temporary has 5610* variable length, the reference count of the associated 5611* length temporary is decremented, and that temporary is 5612* freed if necessary. */ 5613 5614 dcl temp_ptr pointer; /* Pointer to temp node */ 5615 5616 dcl (tp, ltp) pointer; /* To temp, length temp */ 5617 dcl count fixed binary (18); /* Reference count */ 5618 5619 tp = temp_ptr; 5620 5621 if tp -> temporary.variable_length 5622 then do; 5623 5624 /* Must deal with associated length temporary */ 5625 5626 ltp = addr (rands (tp -> temporary.length)); 5627 if ltp -> node.node_type = temporary_node 5628 then do; 5629 if analyzing 5630 then count, ltp -> temporary.ref_count_copy = ltp -> temporary.ref_count_copy - 1; 5631 else count, ltp -> temporary.ref_count = ltp -> temporary.ref_count - 1; 5632 if count <= 0 5633 then call free_one_temp (ltp); 5634 tp -> temporary.length = 0; 5635 tp -> temporary.variable_length = "0"b; 5636 end; 5637 end; 5638 5639 call free_one_temp (tp); 5640 5641 end free_temp; 5642 5643 free_one_temp: 5644 procedure (temp_ptr); 5645 5646 /* This procedure flushes a temporary from the machine state 5647* and threads it onto the appropriate free list. */ 5648 5649 dcl temp_ptr pointer; /* Pointer to temp node */ 5650 5651 dcl tp pointer; /* To temp node */ 5652 dcl (temp, prev_temp, this_temp) fixed binary (18); 5653 dcl temp_size fixed binary (18); 5654 5655 tp = temp_ptr; 5656 temp = fixed (rel (tp), 18); 5657 5658 if tp -> temporary.ms_ref_count < 0 | tp -> temporary.ref_count < 0 | tp -> temporary.ref_count_copy < 0 5659 then do; 5660 call print_message (415, temp); 5661 return; 5662 end; 5663 5664 if unspec (tp -> temporary.address) = "0"b 5665 then do; 5666 5667 /* This temp has no address; it was either used as a 5668* place holder or to give another temp an address. */ 5669 5670 if tp -> temporary.ms_ref_count > 0 /* temp is still a place holder */ 5671 | tp -> temporary.output_by ^= 0 /* temp will be reused in CG pass */ 5672 then return; 5673 tp -> temporary.next = next_free_temp; 5674 next_free_temp = temp; 5675 return; 5676 end; 5677 5678 tp -> temporary.not_in_storage = "1"b; 5679 tp -> temporary.dont_update = "1"b; 5680 tp -> temporary.globally_assigned = "0"b; 5681 5682 temp_size = tp -> temporary.size; 5683 5684 call flush_ref (temp); 5685 call flush_addr (temp); 5686 call disconnect_temp (tp); 5687 5688 /* If the machine state ref count is > 0, the temp cannot be 5689* freed but its storage can be freed. To free the storage, 5690* allocate a new temp and give it the storage; then put the new 5691* temp on the free list. During the analysis pass, temporaries 5692* that are connected to operators cannot be freed because they 5693* will be needed by the CG pass. */ 5694 5695 if tp -> temporary.ms_ref_count > 0 | tp -> temporary.output_by > 0 5696 then do; 5697 this_temp = get_temp_node (); 5698 5699 addr (rands (this_temp)) -> temporary = tp -> temporary; 5700 unspec (tp -> temporary.address) = "0"b; 5701 5702 temp = this_temp; 5703 tp = addr (rands (this_temp)); 5704 tp -> temporary.output_by = 0; 5705 end; 5706 5707 if tp -> temporary.stack_indirect 5708 then do; 5709 5710 /* Restore the address of a dynamic temporary */ 5711 5712 unspec (tp -> temporary.address) = tp -> temporary.addr_hold; 5713 tp -> temporary.address.ext_base = "1"b; 5714 tp -> temporary.needs_pointer = "0"b; 5715 tp -> temporary.is_addressable = ^tp -> temporary.large_address; 5716 tp -> temporary.stack_indirect = "0"b; 5717 end; 5718 5719 /* One and two word temps have their own free lists */ 5720 5721 if temp_size < 3 5722 then do; 5723 call thread_temp (temp, temp_size, 0); 5724 return; 5725 end; 5726 5727 /* Larger temps go on the third free list, sorted by size */ 5728 5729 prev_temp = 0; 5730 this_temp = free_temps (3); 5731 do while (this_temp ^= 0); 5732 5733 if temp_size <= addr (rands (this_temp)) -> temporary.size 5734 then do; 5735 call thread_temp (temp, 3, prev_temp); 5736 return; 5737 end; 5738 5739 prev_temp = this_temp; 5740 this_temp = addr (rands (this_temp)) -> temporary.next; 5741 5742 end; 5743 5744 /* Temp is larger than any on the free list. */ 5745 5746 call thread_temp (temp, 3, prev_temp); 5747 5748 end free_one_temp; 5749 5750 thread_temp: 5751 procedure (temp, chain, prev); 5752 5753 /* Threads temp onto the free list specified by chain after 5754* the temp prev. */ 5755 5756 dcl (temp, chain, prev) fixed binary (18); 5757 5758 if prev = 0 5759 then do; 5760 5761 /* Put temp at beginning of free list */ 5762 5763 addr (rands (temp)) -> temporary.next = free_temps (chain); 5764 free_temps (chain) = temp; 5765 end; 5766 5767 else do; 5768 addr (rands (temp)) -> temporary.next = addr (rands (prev)) -> temporary.next; 5769 addr (rands (prev)) -> temporary.next = temp; 5770 end; 5771 5772 end thread_temp; 5773 5774 disconnect_temp: 5775 procedure (p); 5776 5777 /* Disconnects temp or array_ref from operator that produced it */ 5778 5779 dcl p pointer; 5780 5781 dcl o pointer; 5782 5783 if ^analyzing & p -> temporary.output_by > 0 5784 then do; 5785 o = addr (quad (p -> temporary.output_by)); 5786 o -> operator.output = 0; 5787 p -> temporary.output_by = 0; 5788 end; 5789 5790 end disconnect_temp; 5791 5792 /**** DYNAMIC TEMPORARY MANAGEMENT ****/ 5793 5794 assign_dynamic_temp: 5795 procedure () returns (fixed binary (18)); 5796 5797 /* This procedure allocates and initializes a dynamic 5798* character temporary, but emits no code. Dynamic temps 5799* are implemented as two word temporaries which hold a 5800* pointer to the actual stack extension. */ 5801 5802 dcl t fixed binary (18); /* Two word temp */ 5803 dcl p pointer; /* Pointer to it */ 5804 5805 t = assign_block (2); 5806 p = addr (rands (t)); 5807 5808 p -> temporary.data_type = char_mode; 5809 p -> temporary.stack_indirect = "1"b; 5810 p -> temporary.needs_pointer = "1"b; 5811 p -> temporary.is_addressable = "0"b; 5812 5813 p -> temporary.addr_hold = substr (unspec (p -> temporary.address), 1, 18); 5814 p -> temporary.reloc_hold = p -> temporary.reloc; 5815 5816 unspec (p -> temporary.address) = ext_base_on; 5817 p -> temporary.reloc = rc_a; 5818 5819 return (t); 5820 5821 end assign_dynamic_temp; 5822 5823 allocate_dynamic_temp: 5824 procedure (temp, tv_offset); 5825 5826 /* Emits code to extend the stack for a dynamic temporary. 5827* The parameter tv_offset should be set to either 5828* allocate_char_string or reallocate_char_string. */ 5829 5830 dcl temp fixed binary (18); /* Temporary node */ 5831 dcl tv_offset fixed binary (14); /* Operator offset */ 5832 5833 dcl p pointer; 5834 5835 p = addr (rands (temp)); 5836 5837 call bump_count ((p -> temporary.length), 1); 5838 call load ((p -> temporary.length), in_q); 5839 call use_eaq (0, EAQ, 0); 5840 call flush_base (which_base (2)); 5841 call emit_operator_call ((tv_offset)); 5842 5843 current_ms.stack_extended = "1"b; 5844 current_ms.address_in_base = "1"b; 5845 p -> temporary.address_in_base = "1"b; 5846 p -> temporary.address.base = bases (which_base (2)); 5847 5848 cur_lp -> loop.avoid_pr (which_base (2)) = "1"b; 5849 5850 current_ms.last_dynamic_temp = temp; 5851 5852 current_ms.base_regs (which_base (2)).variable = temp; 5853 current_ms.base_regs (which_base (2)).type = 1; 5854 current_ms.base_regs (which_base (2)).used = text_pos; 5855 current_ms.base_regs (which_base (2)).offset = 0; 5856 5857 end allocate_dynamic_temp; 5858 5859 /**** EMISSION OF OBJECT CODE ****/ 5860 5861 emit_inst: 5862 procedure (); 5863 5864 /* Emits an instruction of object code */ 5865 5866 dcl (inc, rand) fixed binary (18); 5867 5868 if string (machine_instruction (imac).ext_base_and_tag) ^= "0"b 5869 then do; 5870 call check_machine_state (fixed (machine_instruction (imac).op_code, 10), 0); 5871 text_word (text_pos) = unspec (machine_instruction (imac)); 5872 end; 5873 5874 else do; 5875 5876 /* have an operand */ 5877 5878 inc = machine_instruction (imac).increment; 5879 rand = get_operand ((machine_instruction (imac).operand)); 5880 5881 call put_word ((machine_instruction (imac)), (stack (rand)), inc); 5882 end; 5883 5884 text_pos = text_pos + 1; 5885 5886 end emit_inst; 5887 5888 emit_single: 5889 procedure (mac_num, rand); 5890 5891 /* Emits an instruction from a table of single instructions */ 5892 5893 dcl mac_num fixed binary (18), /* Single instruction number */ 5894 rand fixed binary (18); /* Operand for the inst */ 5895 dcl inc fixed binary (18); 5896 5897 inc = fort_opt_macros_$single_inst (mac_num).increment; 5898 5899 call put_word ((fort_opt_macros_$single_inst (mac_num)), (rand), inc); 5900 5901 text_pos = text_pos + 1; 5902 return; 5903 5904 5905 emit_single_with_inc: 5906 entry (mac_num, rand, incr); 5907 5908 /* Emits an instruction with a specified address increment */ 5909 5910 dcl incr fixed binary (18); 5911 5912 inc = incr; 5913 5914 5915 call put_word ((fort_opt_macros_$single_inst (mac_num)), (rand), inc); 5916 5917 text_pos = text_pos + 1; 5918 5919 end emit_single; 5920 5921 emit_with_tag: 5922 procedure (mac_num, address, tag); 5923 5924 /* Emits an instruction with a constant address and a tag field */ 5925 5926 dcl mac_num fixed binary (18), 5927 address fixed binary (18), 5928 tag bit (6) aligned; 5929 5930 dcl 1 inst like machine_instruction aligned; 5931 5932 text_word (text_pos) = unspec (fort_opt_macros_$single_inst (mac_num)) & mask_left; 5933 instruction (text_pos).tag = tag; 5934 text_halfs (text_pos).left = address; 5935 text_pos = text_pos + 1; 5936 return; 5937 end emit_with_tag; 5938 5939 emit_zero: 5940 procedure (mac_num); 5941 5942 /* Emits an instruction without operands */ 5943 5944 dcl mac_num fixed binary (18); 5945 5946 if analyzing 5947 then return; 5948 5949 text_word (text_pos) = unspec (fort_opt_macros_$single_inst (mac_num)); 5950 text_pos = text_pos + 1; 5951 5952 end emit_zero; 5953 5954 emit_c_a: 5955 procedure (mac_num, address); 5956 5957 /* Emits an instruction given an address probably supplied by c_a */ 5958 5959 dcl mac_num fixed binary (18); /* Single instruction number */ 5960 dcl address bit (36) aligned; 5961 5962 if analyzing 5963 then return; 5964 5965 text_word (text_pos) = (unspec (fort_opt_macros_$single_inst (mac_num)) & mask_left) | address; 5966 5967 if fort_opt_macros_$single_inst (mac_num).increment ^= 0 5968 then if instruction (text_pos).ext_base 5969 then instruction (text_pos).offset = 5970 instruction (text_pos).offset + fort_opt_macros_$single_inst (mac_num).increment; 5971 else text_halfs (text_pos).left = 5972 text_halfs (text_pos).left + fort_opt_macros_$single_inst (mac_num).increment; 5973 5974 text_pos = text_pos + 1; 5975 5976 end emit_c_a; 5977 5978 emit_c_a_var: 5979 procedure (mac_num, var_ptr); 5980 5981 /* Emits an instruction and reloc and listing info given an operand whose address 5982* must already be filled in so that m_a need not be called. */ 5983 5984 dcl mac_num fixed binary (18); /* Single instruction number */ 5985 dcl var_ptr pointer; /* Pointer to node for operand */ 5986 5987 if analyzing 5988 then return; 5989 5990 reloc (text_pos).left_rel = var_ptr -> node.reloc; 5991 5992 if assembly_list 5993 then if var_ptr -> node.node_type = array_ref_node 5994 then a_name (text_pos) = var_ptr -> array_ref.parent; 5995 else a_name (text_pos) = binary (rel (var_ptr), 18, 0); 5996 5997 call emit_c_a ((mac_num), unspec (var_ptr -> node.address)); 5998 5999 end emit_c_a_var; 6000 6001 emit_c_a_const: 6002 procedure (mac_num, c_off); 6003 6004 /* Emits an instruction referencing a constant */ 6005 6006 dcl mac_num fixed binary (18); /* Instruction template offset */ 6007 dcl c_off fixed binary (18); /* Const node offset to be used */ 6008 dcl const pointer; 6009 dcl 1 inst like machine_instruction aligned; 6010 6011 if analyzing 6012 then return; 6013 6014 inst = fort_opt_macros_$single_inst (mac_num); 6015 const = addr (rands (c_off)); 6016 6017 text_word (text_pos) = (unspec (inst) & mask_left) | unspec (const -> constant.address); 6018 6019 reloc (text_pos).left_rel = const -> constant.reloc; 6020 6021 call text_ref (const, (inst.increment), fixed (inst.op_code, 10), 0); 6022 6023 text_pos = text_pos + 1; 6024 6025 end emit_c_a_const; 6026 6027 emit_temp_store: 6028 procedure (mac_no, temp); 6029 6030 /* Emits code to store a temporary, indicators are not affected */ 6031 6032 dcl mac_no fixed binary (18); /* Mac num of inst to store temp */ 6033 dcl temp fixed binary (18); /* Node to be stored */ 6034 6035 dcl mac_num fixed binary (18); 6036 dcl p pointer; 6037 6038 mac_num = mac_no; 6039 p = addr (rands (temp)); 6040 6041 if ^p -> node.is_addressable 6042 then call m_a_except_xreg (p); 6043 6044 call emit_c_a_var (mac_num, p); 6045 p -> node.not_in_storage = "0"b; 6046 6047 end emit_temp_store; 6048 6049 emit_operator_call: 6050 procedure (tv_offset); 6051 6052 /* Emits an instruction of the form tsx0 pr0|tv_offset. */ 6053 6054 dcl tv_offset fixed binary (14); 6055 dcl 1 inst aligned like instruction; 6056 6057 if analyzing 6058 then return; 6059 6060 unspec (inst) = ext_base_on; 6061 inst.offset = tv_offset; 6062 inst.op = "1110000000"b; /* 700 (0) - tsx0 */ 6063 6064 text_word (text_pos) = unspec (inst); 6065 text_pos = text_pos + 1; 6066 6067 end emit_operator_call; 6068 6069 put_word: 6070 procedure (inst, p_rand, inc); 6071 6072 /* Uses inst as a template to put out an instruction with 6073* rand as an operand and inc as the increment */ 6074 6075 dcl 1 inst like machine_instruction parameter aligned, 6076 p_rand fixed binary (18), 6077 inc fixed binary (18); 6078 6079 dcl p pointer; 6080 6081 dcl rand fixed binary (18); 6082 dcl mop fixed binary (18); 6083 dcl decrement_address bit (1); 6084 6085 mop = fixed (inst.op_code, 10); 6086 6087 rand = p_rand; 6088 6089 if rand < 0 6090 then do; 6091 if fort_instruction_info_$fort_instruction_info_ (mop).A 6092 | fort_instruction_info_$fort_instruction_info_ (mop).Q 6093 | fort_instruction_info_$fort_instruction_info_ (mop).indicators 6094 then call check_machine_state (mop, 0); 6095 6096 if analyzing 6097 then return; 6098 6099 /* have a count, make it the address */ 6100 6101 text_word (text_pos) = unspec (inst) & mask_left; 6102 6103 /* use direct modifier if possible */ 6104 6105 if directable (mop) 6106 then instruction (text_pos).tag = DL_mod; /* dl */ 6107 6108 text_halfs (text_pos).left = rand + bias + inc; 6109 return; 6110 end; 6111 6112 p = addr (rands (rand)); 6113 6114 if ^p -> node.is_addressable 6115 then do; 6116 if inc ^= 0 6117 then do; 6118 if p -> node.node_type = array_ref_node 6119 then if ^p -> array_ref.has_address 6120 then if analyzing 6121 then call optimized_subscript (addr (quad (p -> array_ref.output_by))); 6122 else do; 6123 call print_message (446, fixed (rel (p), 18)); 6124 stop; 6125 end; 6126 6127 if p -> node.address.ext_base 6128 then do; 6129 call increment_address (p, (inc)); 6130 decrement_address = "1"b; 6131 end; 6132 end; 6133 call m_a (p); 6134 end; 6135 else decrement_address = "0"b; 6136 6137 if fort_instruction_info_$fort_instruction_info_ (mop).A 6138 | fort_instruction_info_$fort_instruction_info_ (mop).Q 6139 | fort_instruction_info_$fort_instruction_info_ (mop).indicators 6140 then call check_machine_state (mop, rand); 6141 6142 if analyzing 6143 then do; 6144 if decrement_address 6145 then call increment_address (p, -inc); 6146 call drop_count (rand, 1); 6147 return; 6148 end; 6149 6150 text_word (text_pos) = (unspec (inst) & mask_left) | unspec (p -> node.address); 6151 6152 reloc (text_pos).left_rel = p -> node.reloc; 6153 6154 if assembly_list 6155 then if p -> node.node_type = array_ref_node 6156 then a_name (text_pos) = p -> array_ref.parent; 6157 else a_name (text_pos) = rand; 6158 6159 if substr (unspec (p -> node.address), 30, 7) = "0000000"b 6160 then call text_ref (p, (inc), mop, 0); 6161 else if inc ^= 0 6162 then if instruction (text_pos).ext_base 6163 then if decrement_address 6164 then call increment_address (p, -inc); 6165 else instruction (text_pos).offset = instruction (text_pos).offset + inc; 6166 else text_halfs (text_pos).left = text_halfs (text_pos).left + inc; 6167 6168 call drop_count (rand, 1); 6169 6170 end put_word; 6171 6172 check_machine_state: 6173 procedure (inst_op_code, sym); 6174 6175 /* Checks if inst to be emitted modifies machine state, if so use_eaq or use_ind is called */ 6176 6177 dcl inst_op_code fixed binary (18); /* Op code of instr to be emitted */ 6178 dcl sym fixed binary (18); /* Variable currently in q or zero */ 6179 dcl opc fixed binary (18); 6180 dcl s fixed binary (18); 6181 dcl reg fixed binary (18); 6182 dcl ( 6183 fstr initial (624), 6184 dfstr initial (628) 6185 ) fixed binary internal static; 6186 6187 opc = inst_op_code; 6188 s = sym; 6189 6190 if fort_instruction_info_$fort_instruction_info_ (opc).A & fort_instruction_info_$fort_instruction_info_ (opc).Q 6191 then reg = EAQ; 6192 6193 else if fort_instruction_info_$fort_instruction_info_ (opc).A 6194 then reg = A; 6195 6196 else if fort_instruction_info_$fort_instruction_info_ (opc).Q 6197 then reg = Q; 6198 6199 else reg = 0; 6200 6201 if reg > 0 6202 then call use_eaq (s, reg, 0); 6203 6204 if fort_instruction_info_$fort_instruction_info_ (opc).indicators 6205 then if reg > 0 6206 then current_ms.indicators_valid = reg; 6207 6208 else if fort_instruction_info_$fort_instruction_info_ (opc).XR 6209 then current_ms.indicators_valid = 6210 index (fort_instruction_info_$fort_instruction_info_ (opc).XR, "1"b) + highest_ind_state; 6211 6212 else if opc = fstr & current_ms.eaq (EAQ).name = in_eaq | opc = dfstr & current_ms.eaq (EAQ).name = in_deaq 6213 then current_ms.indicators_valid = EAQ; 6214 6215 else call use_ind (); 6216 6217 end check_machine_state; 6218 6219 text_ref: 6220 procedure (pt, inc, mop, desc_no); 6221 6222 /* Handles reference to the text section */ 6223 6224 dcl pt pointer; /* Points to addressed node */ 6225 dcl inc fixed binary (18); /* Address increment */ 6226 dcl mop fixed binary (18); /* Instruction opcode */ 6227 dcl desc_no fixed binary (18); /* EIS descriptor number, or 0 */ 6228 6229 dcl temp fixed binary (18); 6230 dcl (p, q) pointer; 6231 dcl use_dl bit (1) aligned; 6232 dcl value bit (36) aligned; 6233 6234 dcl ( 6235 ldq initial ("236"b3), 6236 lcq initial ("336"b3), 6237 adq initial ("076"b3), 6238 sbq initial ("176"b3) 6239 ) bit (10) aligned internal static options (constant); 6240 6241 dcl mf (0:2) fixed binary (6) internal static options (constant) initial (31, 31, 13); 6242 /* Location of MF within instruction */ 6243 6244 6245 p = pt; 6246 6247 q = null (); 6248 if p -> node.node_type = constant_node 6249 then q = addr (p -> constant.value); 6250 else if p -> node.node_type = char_constant_node 6251 then do; 6252 value = unspec (p -> char_constant.value); 6253 q = addr (value); 6254 end; 6255 6256 if q ^= null () 6257 then if inc = 0 6258 then if directable (mop) 6259 then do; 6260 6261 /* Attempt to use DL modification for any constant, 6262* unless it is an operand of an EIS instruction. */ 6263 6264 if (q -> half.left = 0) & (desc_no = 0) 6265 then do; 6266 text_halfs (text_pos).left = q -> half.right; 6267 instruction (text_pos).tag = DL_mod; 6268 /* dl */ 6269 reloc (text_pos).left_rel = rc_a; 6270 return; 6271 end; 6272 6273 /* Attempt to use DU modification for any constant, 6274* unless it is the first operand of an EIS instruction. */ 6275 6276 if (q -> half.right = 0) & (desc_no ^= 1) 6277 then do; 6278 text_halfs (text_pos).left = q -> half.left; 6279 substr (text_word (text_pos - desc_no), mf (desc_no), 6) = DU_mod; 6280 reloc (text_pos).left_rel = rc_a; 6281 return; 6282 end; 6283 6284 if q -> int_image < 0 6285 then do; 6286 6287 /* attempt to optimize negative constants */ 6288 6289 temp = -q -> int_image; 6290 q = addr (temp); 6291 6292 if q -> half.left = 0 6293 then do; 6294 use_dl = "1"b; 6295 6296 if instruction (text_pos).op = ldq 6297 then instruction (text_pos).op = lcq; 6298 6299 else if instruction (text_pos).op = adq 6300 then instruction (text_pos).op = sbq; 6301 6302 else if instruction (text_pos).op = sbq 6303 then instruction (text_pos).op = adq; 6304 6305 else if instruction (text_pos).op = lcq 6306 then instruction (text_pos).op = ldq; 6307 6308 else use_dl = "0"b; 6309 6310 if use_dl 6311 then do; 6312 text_halfs (text_pos).left = q -> half.right; 6313 instruction (text_pos).tag = DL_mod; 6314 reloc (text_pos).left_rel = rc_a; 6315 return; 6316 end; 6317 end; 6318 end; 6319 end; 6320 6321 p -> node.allocate = "1"b; 6322 6323 if ^p -> node.allocated 6324 then do; 6325 text_halfs (text_pos).left = inc; 6326 6327 /* add this forward reference to a list of forward refs */ 6328 6329 if next_free_polish >= polish_max_len 6330 then call print_message (407, "polish region", char (polish_max_len)); 6331 6332 if p -> node.operand_type = external 6333 then p = addr (rands (p -> symbol.initial)); 6334 6335 next_free_polish = next_free_polish + 1; 6336 6337 forward_refs (next_free_polish - 1).operand = fixed (rel (p), 18); 6338 forward_refs (next_free_polish - 1).instruction = text_pos; 6339 6340 end; 6341 6342 else if inc ^= 0 6343 then text_halfs (text_pos).left = text_halfs (text_pos).left + inc; 6344 6345 /* try to use a direct modifier with a rel_constant */ 6346 6347 if p -> node.operand_type = rel_constant 6348 then if directable (mop) 6349 then instruction (text_pos).tag = DL_mod; /* dl */ 6350 6351 end text_ref; 6352 6353 emit_eis: 6354 procedure (); 6355 6356 /* Emits a single EIS instruction, presently assumed to 6357* be 1 instruction word + 2 descriptor words. Only 6358* desc9a is allowed for now. An example follows: 6359* 6360* emit_eis 6361* 6362* mlr (pr),(pr),fill(040) 6363* desc9a op1 6364* desc9a arg2+3 6365* 6366* If the length field is omitted, which is the usual 6367* case, the interpreter supplies it. The interpreter 6368* supplies the Modification Fields. All operands are 6369* assumed to be character strings. If the equal_lengths 6370* keyword is given, the length of the second operand is 6371* taken to be identical to the length of the first. */ 6372 6373 dcl arg (2) pointer; 6374 dcl op (2) fixed binary (18); 6375 dcl len (2) fixed binary (18); 6376 dcl lreg (2) bit (6) aligned; 6377 dcl inc (2) fixed binary (18); 6378 dcl opcode bit (10) aligned; 6379 6380 dcl 1 descriptor (0:262143) based (object_base) aligned, 6381 2 word_address bit (18) unaligned, 6382 2 char bit (2) unaligned, 6383 2 bit bit (4) unaligned, 6384 2 length bit (12) unaligned; 6385 6386 dcl mf (3) fixed binary (6) internal static options (constant) initial (30, 12, 3); 6387 6388 dcl ( 6389 cmpc initial ("0010001101"b), /* 106 (1) */ 6390 scm initial ("0010101001"b), /* 124 (1) */ 6391 scd initial ("0010100001"b) 6392 ) /* 120 (1) */ 6393 bit (10) aligned internal static options (constant); 6394 6395 dcl (i, inst_pos) fixed binary (18); 6396 6397 dcl bit builtin; 6398 6399 imac = imac + 1; /* point at the instruction */ 6400 6401 /* pick up the operands and address increments */ 6402 6403 do i = 1 to 2; 6404 op (i) = stack (get_operand ((machine_instruction (imac + i).operand))); 6405 arg (i) = addr (rands (op (i))); 6406 inc (i) = machine_instruction (imac + i).increment; 6407 lreg (i) = "00"b3; 6408 end; 6409 6410 /* Make operands addressable, reserving registers as needed */ 6411 6412 call make_both_addressable (arg, inc); 6413 6414 /* Get lengths of operands, reserving registers as needed */ 6415 6416 call get_eis_length (1); /* Get length of 1st opnd */ 6417 6418 if left > 0 /* Equal lengths? */ 6419 then if mac_base -> descriptor (imac + 2).length = "000"b3 6420 then do; 6421 6422 /* Copy length info from 1st opnd to 2nd */ 6423 6424 len (2) = len (1); 6425 lreg (2) = lreg (1); 6426 end; 6427 6428 else call print_message (466); 6429 6430 else call get_eis_length (2); /* Get length for opnd 2 */ 6431 6432 /* Move in the instruction word */ 6433 6434 inst_pos = text_pos; 6435 text_word (text_pos) = unspec (machine_instruction (imac)); 6436 opcode = machine_instruction (imac).op_code; 6437 6438 /* fill in the descriptors and modification fields */ 6439 6440 do i = 1 to 2; 6441 imac = imac + 1; 6442 text_pos = text_pos + 1; 6443 6444 substr (text_word (inst_pos), mf (i), 7) = substr (unspec (arg (i) -> node.address), 30, 7); 6445 6446 if lreg (i) 6447 then substr (text_word (inst_pos), mf (i) + 1, 1) = "1"b; 6448 6449 /* Fill in address of descriptor, including char and bit offsets */ 6450 6451 substr (unspec (descriptor (text_pos)), 1, 24) = substr (unspec (arg (i) -> node.address), 1, 20); 6452 6453 if lreg (i) 6454 then descriptor (text_pos).length = (6)"0"b || lreg (i); 6455 else descriptor (text_pos).length = bit (fixed (len (i), 12), 12); 6456 6457 if ^analyzing 6458 then reloc (text_pos).left_rel = arg (i) -> node.reloc; 6459 6460 if assembly_list & ^analyzing 6461 then if arg (i) -> node.node_type = array_ref_node 6462 then a_name (text_pos) = arg (i) -> array_ref.parent; 6463 else a_name (text_pos) = op (i); 6464 6465 if substr (unspec (arg (i) -> node.address), 30, 7) = "0"b & ^analyzing 6466 then call text_ref (arg (i), inc (i), fixed (opcode, 10), i); 6467 else if inc (i) ^= 0 6468 then if arg (i) -> node.ext_base 6469 then if ^arg (i) -> node.is_addressable 6470 then call increment_address (arg (i), -inc (i)); 6471 else instruction (text_pos).offset = instruction (text_pos).offset + inc (i); 6472 else text_halfs (text_pos).left = text_halfs (text_pos).left + inc (i); 6473 6474 /* If the output of this EIS instruction (its second 6475* operand) is a temporary, do not drop its reference 6476* count. Note that the cmpc, scd, and scm instructions 6477* have no outputs in this sense. */ 6478 6479 if i = 1 /* Always drop 1st operand */ 6480 | arg (i) -> node.node_type = array_ref_node 6481 /* Always drop array refs */ 6482 | opcode = cmpc /* Has no output */ 6483 | opcode = scd /* Has no output */ 6484 | opcode = scm /* Has no output */ 6485 then call drop_count ((op (i)), 1); 6486 6487 end; 6488 6489 text_pos = text_pos + 1; 6490 6491 /* Free regs used by addresses and lengths of EIS operands */ 6492 6493 call free_regs (); 6494 6495 return; 6496 6497 get_eis_length: 6498 procedure (opno); 6499 6500 /* Internal procedure to emit_eis. Computes the length of the 6501* specified operand of the EIS instruction, setting len and 6502* lreg. */ 6503 6504 dcl (opno, i) fixed binary; /* Operand number */ 6505 dcl csize fixed binary (18); /* Character size of opnd */ 6506 6507 i = opno; 6508 6509 if mac_base -> descriptor (imac + i).length = "000"b3 6510 then do; 6511 6512 /* Length not given, figure it out */ 6513 6514 csize = get_char_size ((arg (i))); 6515 if csize < 0 6516 then len (i) = csize + bias; 6517 else do; 6518 if addr (rands (csize)) -> node.value_in.eaq 6519 then lreg (i) = eaq_man_load_a_or_q (addr (rands (csize))); 6520 else lreg (i) = xr_man_load_any_xr (addr (rands (csize))); 6521 len (i) = 0; 6522 end; 6523 end; 6524 6525 else len (i) = fixed (mac_base -> descriptor (imac + i).length, 12); 6526 6527 /* If constant length will not fit in 12 bits, put it in an index register */ 6528 6529 if len (i) > 4095 6530 then lreg (i) = xr_man_load_const (len (i)); 6531 6532 /* Reserve the register used for length */ 6533 6534 call lock_tag_register ((lreg (i))); 6535 6536 end get_eis_length; 6537 6538 end emit_eis; 6539 6540 /**** ADDRESSING SECTION ****/ 6541 6542 m_a: 6543 procedure (pt); 6544 6545 /* make_addressable */ 6546 6547 dcl (p, pt, s, v) pointer; 6548 dcl off fixed binary (18); 6549 6550 p = pt; 6551 6552 if p -> node.is_addressable 6553 then return; 6554 6555 if p -> node.address_in_base 6556 then do; 6557 p -> node.address.base = base_man_load_any_pr (1, fixed (rel (p), 17), 0); 6558 return; 6559 end; 6560 6561 if p -> node.node_type = array_ref_node 6562 then do; 6563 s = addr (rands (p -> array_ref.parent)); 6564 if ^p -> array_ref.has_address 6565 then if analyzing 6566 then call optimized_subscript (addr (quad (p -> array_ref.output_by))); 6567 else do; 6568 call print_message (446, fixed (rel (p), 18)); 6569 stop; 6570 end; 6571 6572 if p -> array_ref.variable_offset 6573 then do; 6574 off = p -> array_ref.v_offset; 6575 v = addr (rands (off)); 6576 if p -> array_ref.large_offset | (^analyzing & v -> node.value_in.eaq) 6577 then do; 6578 6579 /* Process array-ref of VLA. 'v' is the total Packed Pointer. If it is in 6580* the Q or A register then we leave it and will later use epp,easp, else if 6581* it is in storage then we can use an lprp. */ 6582 6583 if ^s -> symbol.VLA 6584 then p -> array_ref.address.tag = eaq_man_load_a_or_q (v); 6585 end; 6586 else p -> array_ref.address.tag = xr_man_load_any_xr (v); 6587 end; 6588 6589 end; 6590 6591 call m_a_except_xreg (p); 6592 6593 if p -> node.data_type = char_mode & p -> node.units ^= char_units 6594 then do; 6595 if ^from_base_man 6596 then if p -> node.address.tag 6597 then do; 6598 p -> node.addr_hold = substr (unspec (p -> node.address), 1, 18); 6599 p -> node.reloc_hold = p -> node.reloc; 6600 p -> node.address.base = base_man_load_any_pr (1, fixed (rel (p), 17), 0); 6601 p -> node.address.offset = 0; 6602 p -> node.address.tag = "0"b; 6603 p -> node.reloc = rc_a; 6604 end; 6605 end; 6606 6607 end m_a; 6608 6609 m_a_except_xreg: 6610 procedure (pt); 6611 6612 /* make_addressable, but don't call xr_man and don't do special aligned character addressing */ 6613 6614 dcl (p, pt) pointer; /* Node to be made addressable */ 6615 dcl p1 pointer; /* Node to get addressing info from */ 6616 dcl (i, offset) fixed binary (18); 6617 6618 p = pt; 6619 6620 if p -> node.node_type = array_ref_node 6621 then p1 = addr (rands (p -> array_ref.parent)); 6622 else do; 6623 p1 = p; 6624 if analyzing 6625 then if unspec (p -> node.address) = "0"b 6626 then if p -> node.node_type = temporary_node 6627 then call assign_address_to_temp (fixed (rel (p), 18), 0); 6628 end; 6629 6630 if p1 -> node.needs_pointer 6631 then do; 6632 6633 if last_pr_locked_for_pl1_ops_arg > 0 6634 then cur_lp -> loop.avoid_pr (last_pr_locked_for_pl1_ops_arg) = "1"b; 6635 6636 /* prevent a multi-position VLA parameter from missing VLA processing. */ 6637 6638 if p1 -> node.stack_indirect & ^(p1 -> node.node_type = symbol_node & p1 -> symbol.VLA) 6639 then do; 6640 i = 4; 6641 if p1 -> node.node_type = temporary_node 6642 then do; 6643 offset = fixed (substr (p1 -> node.addr_hold, 4, 15), 15); 6644 if offset >= 16384 6645 then offset = offset - 32768; 6646 if p1 -> temporary.large_address 6647 then offset = offset + p1 -> temporary.location; 6648 p -> temporary.address.base = base_man_load_any_pr (i, offset, 0); 6649 return; 6650 end; 6651 end; 6652 6653 /* Must be a symbol node */ 6654 6655 else if p1 -> symbol.VLA 6656 then do; 6657 p -> node.address.base = base_man_load_any_pr (1, fixed (rel (p), 17, 0), 0); 6658 return; 6659 end; /* we are pointer at our pointer */ 6660 else if p1 -> symbol.LA 6661 then do; 6662 if p1 -> symbol.static 6663 then i = 11; /* static indirect */ 6664 else i = 4; /* stack */ 6665 p1 = addr (rands (p1 -> symbol.parent)); 6666 end; 6667 else if p1 -> symbol.in_common 6668 then do; 6669 i = 3; 6670 p1 = addr (rands (p1 -> symbol.parent)); 6671 end; 6672 else if p1 -> symbol.parameter 6673 then i = 2; 6674 else if p1 -> symbol.descriptor 6675 then i = 10; 6676 else do; 6677 call print_message (417, fixed (rel (p), 18)); 6678 return; 6679 end; 6680 6681 if ^p -> symbol.large_address 6682 then p -> symbol.address.base = base_man_load_any_pr (i, (p1 -> node.location), 0); 6683 else p -> symbol.address.base = base_man_load_any_pr (i, (p1 -> node.location), (p -> symbol.location)); 6684 end; 6685 6686 else if p1 -> node.node_type = symbol_node 6687 then do; 6688 if p1 -> symbol.external & p1 -> symbol.initial ^= 0 6689 then do; 6690 6691 /* have an external subr or func reference 6692* that is really local */ 6693 6694 p1 = addr (rands (p1 -> symbol.initial)); 6695 6696 if p1 -> symbol.allocated & ^analyzing 6697 then do; 6698 unspec (p -> symbol.address) = unspec (p1 -> symbol.address); 6699 p -> symbol.allocated, p -> symbol.is_addressable = "1"b; 6700 end; 6701 end; 6702 6703 else if p1 -> symbol.parameter 6704 then p -> node.address.base = base_man_load_arg_ptr (); 6705 6706 else call m_a_check_large_address (p, p1); 6707 end; 6708 6709 else call m_a_check_large_address (p, p1); 6710 6711 end m_a_except_xreg; 6712 6713 m_a_check_large_address: 6714 procedure (pt, pt1); 6715 6716 /* Handles large addresses */ 6717 6718 dcl (pt, p, pt1, p1) pointer; 6719 dcl usual_base bit (3) aligned; 6720 dcl i fixed binary (18); 6721 6722 p = pt; 6723 p1 = pt1; 6724 6725 if p -> node.large_address 6726 then do; 6727 6728 /* have abs(address) >= 16K */ 6729 6730 if last_pr_locked_for_pl1_ops_arg > 0 6731 then cur_lp -> loop.avoid_pr (last_pr_locked_for_pl1_ops_arg) = "1"b; 6732 6733 usual_base = sp; 6734 if p1 -> node.node_type = symbol_node 6735 then if p1 -> symbol.static | p1 -> symbol.external 6736 then usual_base = lp; 6737 6738 i = p -> node.location; 6739 6740 if i ^= 0 6741 then p -> node.address.base = base_man_load_large_base (i, usual_base); 6742 6743 else p -> node.address.base = usual_base; 6744 6745 end; 6746 6747 end m_a_check_large_address; 6748 6749 increment_address: 6750 procedure (p, inc); 6751 6752 /* Applies increment to address of node */ 6753 6754 dcl p pointer, 6755 inc fixed binary (18); 6756 6757 dcl (loc, offset) fixed binary (18); 6758 6759 if ^p -> node.large_address 6760 then p -> node.address.offset = p -> node.address.offset + inc; 6761 6762 else do; 6763 loc, offset = p -> node.address.offset + p -> node.location + inc; 6764 offset = mod (offset + 16384, 32768) - 16384; 6765 p -> node.location = loc - offset; 6766 p -> node.address.offset = offset; 6767 end; 6768 6769 end increment_address; 6770 6771 c_a: 6772 procedure (c, code) returns (bit (36) aligned); 6773 6774 /* Fabricates a constant address to be used with emit_c_a */ 6775 6776 dcl (c, n, code) fixed binary (18); 6777 6778 dcl 1 inst_address aligned like symbol.address; 6779 6780 n = c; 6781 unspec (inst_address) = "0"b; 6782 go to sw (code); 6783 6784 sw (1): /* n,ql */ 6785 inst_address.tag = QL_mod; 6786 go to exit; 6787 6788 sw (5): /* location n in the linkage section */ 6789 inst_address.base = lp; 6790 go to set_ext_base; 6791 6792 sw (6): /* location n in the stack */ 6793 inst_address.base = sp; 6794 go to set_ext_base; 6795 6796 sw (3): /* location n indirect in linkage section */ 6797 sw (11): /* location n indirect in static section */ 6798 inst_address.base = lp; 6799 go to indirect; 6800 6801 sw (4): /* location n indirect in stack */ 6802 inst_address.base = sp; 6803 6804 indirect: 6805 inst_address.tag = inst_address.tag | "010000"b; 6806 6807 set_ext_base: 6808 inst_address.ext_base = "1"b; 6809 6810 if n >= 16384 6811 then do; 6812 n = mod (n + 16384, 32768) - 16384; 6813 inst_address.base = base_man_load_large_base (c - n, (inst_address.base)); 6814 end; 6815 6816 exit: 6817 inst_address.offset = n; 6818 return (unspec (inst_address)); 6819 6820 end c_a; 6821 6822 c_a_18: 6823 procedure (n, code) returns (bit (36) aligned); 6824 6825 /* Fabricates a constant address with 18 bit offset field for use with emit_c_a */ 6826 6827 dcl n fixed binary (18), /* Offset */ 6828 code fixed binary (18); /* 1 = DU */ 6829 6830 dcl 1 inst_address aligned, 6831 2 offset fixed binary (17) unaligned, 6832 2 op_code bit (10) unaligned, 6833 2 inhibit bit (1) unaligned, 6834 2 ext_base bit (1) unaligned, 6835 2 tag bit (6) unaligned; 6836 6837 unspec (inst_address) = "0"b; 6838 6839 inst_address.offset = n; 6840 6841 if code = 1 6842 then inst_address.tag = DU_mod; 6843 6844 return (unspec (inst_address)); 6845 6846 end c_a_18; 6847 6848 c_a_tag: 6849 procedure (n) returns (bit (36) aligned); 6850 6851 /* Fabricates a constant address with a specified tag */ 6852 6853 dcl n fixed binary (3); 6854 dcl 1 inst_address aligned like symbol.address; 6855 6856 unspec (inst_address) = "0"b; 6857 inst_address.tag = "001"b || bit (n, 3); 6858 return (unspec (inst_address)); 6859 6860 end c_a_tag; 6861 6862 make_both_addressable: 6863 procedure (arg, inc); 6864 6865 /* Makes two operands simultaneously addressable by reserving 6866* registers as it goes. */ 6867 6868 dcl arg (2) pointer; 6869 dcl inc (2) fixed binary (18); 6870 dcl (i, reg) fixed binary (3); 6871 dcl p pointer; 6872 6873 do i = 1 to 2; 6874 6875 p = arg (i); 6876 6877 if ^p -> node.is_addressable 6878 then do; 6879 6880 if inc (i) ^= 0 6881 then do; 6882 if p -> node.node_type = array_ref_node 6883 then if ^p -> array_ref.has_address 6884 then if analyzing 6885 then call optimized_subscript (addr (quad (p -> array_ref.output_by))); 6886 else do; 6887 call print_message (446, fixed (rel (p), 18)); 6888 stop; 6889 end; 6890 if p -> node.address.ext_base 6891 then call increment_address (p, (inc (i))); 6892 end; 6893 6894 call m_a (p); 6895 6896 /* Reserve any XRs or EAQ registers used */ 6897 6898 call lock_tag_register ((p -> node.address.tag)); 6899 6900 /* Reserved any base registers used */ 6901 6902 if p -> node.address.ext_base 6903 then do; 6904 reg = which_base (fixed (p -> node.address.base, 3)); 6905 call lock_base (reg); 6906 end; 6907 6908 end; 6909 6910 end; 6911 6912 end make_both_addressable; 6913 6914 /**** POINTER REGISTER MANAGEMENT ****/ 6915 6916 /* The contents of the pointer registers are determined by the 6917* value of the type field as follows: 6918* (v = variable field) 6919* 6920* -1 UNKNOWN 6921* 0 EMPTY 6922* 1 address of operand specified by v (usually an aligned char-string) 6923* 2 ptr to loc v in arg list 6924* 3 ptr thru link with offset v 6925* 4 ptr at stack offset v 6926* 5 arg list ptr 6927* 6 linkage ptr 6928* 7 value of operand specified by v 6929* 8 stack ptr 6930* 9 ptr to arg descriptor list 6931* 10 ptr to loc v in desc list 6932* 11 ptr thru static with offset v 6933* */ 6934 6935 base_man_load_any_pr: 6936 procedure (code, num, offset) returns (bit (3) aligned); 6937 6938 dcl (n, code) fixed binary (18), /* type of operation */ 6939 (v, num) fixed binary (18), /* location of ptr to be loaded */ 6940 (off, offset) fixed binary (18); /* offset to be added to pointer */ 6941 6942 dcl VLA bit (1); /* True if VLA */ 6943 dcl s ptr; 6944 6945 dcl (i, j, k) fixed binary (3); 6946 dcl address bit (36) aligned; 6947 dcl diff fixed binary (18); 6948 6949 n = code; 6950 v = num; 6951 diff, off = offset; 6952 6953 if analyzing 6954 then if n ^= 1 6955 then call add_global_ptr (n, v, off); 6956 6957 j, k = 0; 6958 6959 do i = first_base to last_base; 6960 if current_ms.base_regs (i).type = 0 6961 then k = i; 6962 else if current_ms.base_regs (i).type = n 6963 then if current_ms.base_regs (i).variable = v 6964 then if current_ms.base_regs (i).offset = off 6965 then do; 6966 current_ms.base_regs (i).used = text_pos; 6967 return (bases (i)); 6968 end; 6969 else j = i; 6970 end; 6971 6972 if j > 0 6973 then do; 6974 6975 /* we've got the right storage area, but the wrong offset */ 6976 6977 diff = off - current_ms.base_regs (j).offset; 6978 address = c_a (0, 6); 6979 substr (address, 1, 3) = bases (j); 6980 6981 i = get_free_reg (current_ms.base_regs, first_base, last_base, find_global_base (n, v, off), k); 6982 6983 call flush_base (i); 6984 6985 call emit_c_a ((load_base (i)), address); 6986 end; 6987 6988 else if n = 1 6989 then do; 6990 s = addr (rands (v)); 6991 if s -> node.node_type = symbol_node 6992 then VLA = s -> symbol.VLA; 6993 else if s -> node.node_type = array_ref_node 6994 then VLA = addr (rands (s -> array_ref.parent)) -> symbol.VLA; 6995 else VLA = "0"b; 6996 s -> node.address_in_base = "1"b; 6997 current_ms.address_in_base = "1"b; 6998 6999 i = get_free_reg (current_ms.base_regs, first_base, last_base, find_global_base (n, v, off), k); 7000 7001 call flush_base (i); 7002 7003 /* A very large reference can be of two types: 7004* 1. array-reference. in this case the vsum of the reference is in memory 7005* and is the total addressor needed by lprp. 7006* 2. normal-reference. in this case the address in the symbol node is 7007* sufficient to address directly a base to the variable for 7008* lprp. 7009* */ 7010 7011 if VLA 7012 then call base_man_load_VLA (v, i); 7013 else call emit_c_a_var ((load_base (i)), addr (rands (v))); 7014 7015 if analyzing 7016 then call add_local_ptr; 7017 end; 7018 7019 else if n = 2 | n = 10 7020 then do; 7021 address = c_a (v, 4); 7022 if n = 2 7023 then substr (address, 1, 3) = base_man_load_arg_ptr (); 7024 else substr (address, 1, 3) = base_man_load_desc_ptr (); 7025 7026 i = get_free_reg (current_ms.base_regs, first_base, last_base, find_global_base (n, v, off), 0); 7027 7028 call flush_base (i); 7029 7030 call emit_c_a ((load_base (i)), address); 7031 end; 7032 7033 else do; 7034 address = c_a (v, n); 7035 7036 if v >= 16384 7037 then k = 0; /* base_regs state was changed. */ 7038 7039 i = get_free_reg (current_ms.base_regs, first_base, last_base, find_global_base (n, v, off), k); 7040 7041 call flush_base (i); 7042 7043 if ^analyzing 7044 then if n = 3 /* linkage indirect */ 7045 then reloc (text_pos).left_rel = rc_lp15; 7046 else if n = 11 /* static indirect */ 7047 then reloc (text_pos).left_rel = rc_is15; 7048 7049 call emit_c_a ((load_base (i)), address); 7050 end; 7051 7052 if diff ^= 0 7053 then call emit_c_a ((add_base (i)), c_a_18 (diff, 1)); 7054 7055 current_ms.base_regs (i).type = n; 7056 current_ms.base_regs (i).variable = v; 7057 current_ms.base_regs (i).offset = off; 7058 current_ms.base_regs (i).used = text_pos; 7059 return (bases (i)); 7060 7061 end base_man_load_any_pr; 7062 7063 base_man_load_VLA: 7064 proc (opnd, which); 7065 7066 dcl opnd fixed bin (18), 7067 which fixed bin (3); 7068 7069 dcl llr_18_instruction bit (36) aligned static options (constant) init ("00002277700"b3); 7070 7071 dcl offset fixed bin (18), 7072 p ptr, 7073 storage_class fixed bin (18), 7074 v ptr, 7075 v_offset fixed bin (18); 7076 7077 p = addr (rands (opnd)); 7078 if p -> node.node_type = array_ref_node 7079 then do; 7080 v_offset = p -> array_ref.v_offset; 7081 v = addr (rands (v_offset)); 7082 if ^v -> node.not_in_storage 7083 then call emit_c_a_var (load_packed_base (which), v); 7084 else if get_eaq_name (v_offset) ^= in_q & ^analyzing 7085 then call print_message (440, "addressing a VLA element"); 7086 /* Addressor must be in Q if not in storage. */ 7087 else if text_word (max (0, text_pos - 1)) = llr_18_instruction 7088 then do; /* We just expanded a 'form_VLA_packed_ptr' macro. */ 7089 text_pos = text_pos - 2; /* Backup to 'div pr0|VLA_words_per_seg'. */ 7090 call emit_c_a (load_base (which), (30)"0"b || AL_mod); 7091 call emit_c_a (load_segment_num (which), (30)"0"b || QL_mod); 7092 if get_ref_count (p) > 1 | get_ref_count (v) > 1 7093 then call emit_temp_store (store_packed_base (which), v_offset); 7094 else v -> temporary.not_in_storage = "0"b; 7095 /* A small lie to prevent storing of the subscript. */ 7096 end; 7097 else if get_ref_count (p) > 1 | get_ref_count (v) > 1 7098 then do; 7099 call emit_temp_store (store_inst (get_eaq_name (v_offset)), v_offset); 7100 call emit_c_a_var (load_packed_base (which), v); 7101 end; 7102 else do; 7103 call emit_c_a (load_base (which), (30)"0"b || QL_mod); 7104 call emit_c_a (load_segment_num (which), (30)"0"b || QU_mod); 7105 v -> temporary.not_in_storage = "0"b; /* A small lie to prevent storing of the subscript. */ 7106 end; 7107 end; 7108 else if p -> node.node_type = symbol_node 7109 then do; 7110 7111 /* for non-dimensioned symbols, use the saved offset information. */ 7112 if ^p -> symbol.dimensioned 7113 then substr (unspec (p -> symbol.address), 1, 18) = p -> symbol.addr_hold; 7114 offset = p -> symbol.address.offset; 7115 if p -> symbol.large_address 7116 then offset = offset + p -> symbol.location; 7117 if p -> symbol.in_common | p -> symbol.static 7118 then storage_class = 5; 7119 else storage_class = 6; 7120 if assembly_list 7121 then a_name (text_pos) = opnd; 7122 reloc (text_pos).left_rel = p -> symbol.reloc; 7123 call emit_c_a (load_packed_base (which), c_a (offset, storage_class)); 7124 7125 /* Zero the offset in non-dimensioned symbols since all 7126* references through the pointer just created must be 7127* prN|0 references. */ 7128 if ^p -> symbol.dimensioned 7129 then p -> symbol.address.offset = 0; 7130 end; 7131 else call print_message (470, opnd, "base_man_load_VLA"); 7132 end base_man_load_VLA; 7133 7134 flush_base: 7135 procedure (i); 7136 7137 /* Empties a pointer register prior to reuse. */ 7138 7139 dcl i fixed binary (3); /* base reg to flush */ 7140 dcl p pointer; 7141 7142 if current_ms.base_regs (i).type = 1 7143 then do; 7144 p = addr (rands (current_ms.base_regs (i).variable)); 7145 p -> node.address_in_base = "0"b; 7146 7147 if p -> node.stack_indirect 7148 then if p -> node.node_type = temporary_node 7149 then if p -> temporary.not_in_storage 7150 then do; 7151 7152 /* Store pointer to dynamic temp */ 7153 7154 call base_man_store_temp (p, (i)); 7155 ptr_data.local = ptr_data.local - 1; 7156 return; 7157 end; 7158 7159 /* Restore address of aligned character string */ 7160 7161 substr (unspec (p -> node.address), 1, 18) = p -> node.addr_hold; 7162 p -> node.reloc = p -> node.reloc_hold; 7163 ptr_data.local = ptr_data.local - 1; 7164 end; 7165 7166 else if current_ms.base_regs (i).type = 7 7167 then ptr_data.local = ptr_data.local - 1; 7168 7169 end flush_base; 7170 7171 base_man_load_pr: 7172 procedure (opnd, which, lock_it); 7173 7174 /* Loads the address of an operand into the 7175* specified register and reserves the register 7176* if asked to do so */ 7177 7178 dcl opnd fixed binary (18), /* Index of operand */ 7179 which fixed binary (18), /* Register to use */ 7180 lock_it bit (1) aligned; 7181 7182 dcl i fixed binary (3); 7183 dcl op fixed binary (18); 7184 dcl p pointer; 7185 dcl 1 inst_address aligned like node.address; 7186 dcl tag_hold bit (6) aligned; 7187 dcl char_num_hold fixed binary (2) aligned; 7188 dcl VLA bit (1); 7189 7190 from_base_man = "1"b; 7191 7192 i = which; 7193 op = opnd; 7194 p = addr (rands (op)); 7195 7196 /* force addressability so we can look at the address */ 7197 7198 if p -> node.node_type = symbol_node 7199 then VLA = p -> symbol.VLA; 7200 else if p -> node.node_type = array_ref_node 7201 then VLA = addr (rands (p -> array_ref.parent)) -> symbol.VLA; 7202 else VLA = "0"b; 7203 7204 if ^p -> node.is_addressable & ^VLA /* VLA is always addressable */ 7205 then call m_a (p); 7206 7207 if p -> node.units = char_units 7208 then do; 7209 7210 /* Tag specifies a character offset in a register. Save 7211* the tag, so epp does not use it, and deal with it 7212* manually below. Do the same for char_num. */ 7213 7214 tag_hold = p -> node.address.tag; 7215 p -> node.address.tag = "00"b3; 7216 char_num_hold = p -> node.address.char_num; 7217 p -> node.address.char_num = 0; 7218 end; 7219 7220 call flush_base (i); 7221 7222 /* If we are dealing in char_units, then we want to avoid 7223* calling m_a and setting node.address.tag. Therefore, 7224* we use emit_c_a_var instead of emit_single. */ 7225 7226 if p -> node.address.base ^= bases (i) | ^p -> node.address.ext_base | p -> node.address.offset ^= 0 7227 | p -> node.address.tag ^= "00"b3 7228 then if p -> node.units = char_units /* characters cannot be VLA's so no code here. */ 7229 then do; 7230 call emit_c_a_var ((load_base (i)), p); 7231 call drop_count (op, 1); 7232 end; 7233 else if VLA 7234 then call base_man_load_VLA (op, i); 7235 else call emit_single ((load_base (i)), op); 7236 else call drop_count (op, 1); 7237 7238 if p -> node.units = char_units 7239 then do; 7240 7241 /* Handle character offsets */ 7242 7243 unspec (inst_address) = ext_base_on; /* Initialize address for a9bd instructions */ 7244 inst_address.base = bases (i); 7245 7246 if char_num_hold ^= 0 7247 then if tag_hold & "001000"b 7248 then do; 7249 7250 /* Have constant offset + offset in XR */ 7251 7252 inst_address.tag = xr_man_add_const (binary (substr (tag_hold, 4, 3), 3), (char_num_hold)); 7253 call emit_c_a (a9bd, unspec (inst_address)); 7254 end; 7255 7256 else if tag_hold ^= "00"b3 7257 then do; 7258 7259 /* have constant offset + offset not in XR */ 7260 7261 inst_address.tag = xr_man_load_const ((char_num_hold)); 7262 call emit_c_a (a9bd, unspec (inst_address)); 7263 inst_address.tag = tag_hold; 7264 call emit_c_a (a9bd, unspec (inst_address)); 7265 end; 7266 7267 else do; 7268 7269 /* Constant offset only */ 7270 7271 inst_address.tag = xr_man_load_const ((char_num_hold)); 7272 call emit_c_a (a9bd, unspec (inst_address)); 7273 end; 7274 7275 else if tag_hold ^= "00"b3 7276 then do; 7277 7278 /* Variable offset only */ 7279 7280 inst_address.tag = tag_hold; 7281 call emit_c_a (a9bd, unspec (inst_address)); 7282 end; 7283 7284 p -> node.address.tag = tag_hold; /* Restore original tag */ 7285 p -> node.address.char_num = char_num_hold; /* and char_num */ 7286 7287 end; 7288 7289 current_ms.base_regs (i).variable = op; /* debugging */ 7290 current_ms.base_regs (i).offset = 0; 7291 current_ms.base_regs (i).used = text_pos; 7292 7293 if lock_it 7294 then do; 7295 current_ms.base_regs (i).type = -1; /* unknown value */ 7296 call lock_base (i); 7297 if analyzing & i >= first_base & i <= last_base 7298 then last_pr_locked_for_pl1_ops_arg = i; 7299 end; 7300 else current_ms.base_regs (i).type = 0; /* empty */ 7301 7302 if analyzing 7303 then do; 7304 cur_lp -> loop.erases.pr (i) = "1"b; 7305 ptr_data.max_local = max (ptr_data.max_local, ptr_data.local + 1); 7306 end; 7307 7308 from_base_man = "0"b; 7309 7310 end base_man_load_pr; 7311 7312 base_man_load_pr_value: 7313 procedure (opnd, which); 7314 7315 /* Loads the value of an operand into the specified register */ 7316 7317 dcl opnd fixed binary (18), /* Index of operand */ 7318 which fixed binary (18); /* Register to use */ 7319 7320 dcl i fixed binary (3); 7321 dcl op fixed binary (18); 7322 dcl p pointer; 7323 7324 op = opnd; 7325 p = addr (rands (op)); 7326 i = which; 7327 7328 /* load value if it is not loaded already */ 7329 7330 if current_ms.base_regs (i).type ^= 7 | current_ms.base_regs (i).variable ^= op 7331 | current_ms.base_regs (i).offset ^= 0 7332 then do; 7333 7334 /* force addressability so we can look at the address */ 7335 7336 if ^p -> node.is_addressable 7337 then call m_a (p); 7338 7339 call flush_base (i); 7340 7341 if substr (p -> node.address.tag, 1, 2) /* node addr already has a modifier */ 7342 then call print_message (416, op); /* illegal address field */ 7343 7344 substr (p -> node.address.tag, 1, 2) = "01"b;/* RI */ 7345 7346 call emit_c_a_var ((load_base (i)), p); 7347 7348 substr (p -> node.address.tag, 1, 2) = "00"b;/* restore tag */ 7349 7350 current_ms.base_regs (i).type = 7; /* value of op in pr */ 7351 current_ms.base_regs (i).variable = op; /* debugging */ 7352 current_ms.base_regs (i).offset = 0; 7353 7354 if analyzing 7355 then do; 7356 cur_lp -> loop.erases.pr (i) = "1"b; 7357 call add_local_ptr; 7358 end; 7359 end; 7360 7361 current_ms.base_regs (i).used = text_pos; 7362 7363 end base_man_load_pr_value; 7364 7365 base_man_load_large_base: 7366 procedure (offset, base) returns (bit (3) aligned); 7367 7368 /* Loads pointer register with contents(base) + offset. 7369* This routine is used to deal with address offsets >= 16K. */ 7370 7371 dcl (off, offset) fixed binary (18), 7372 base bit (3) aligned; /* MUST BE sp or lp */ 7373 7374 dcl (i, k) fixed binary (3); 7375 dcl code fixed binary (18); 7376 dcl 1 inst_address aligned like symbol.address; 7377 7378 off = offset; 7379 7380 if base = lp 7381 then code = 6; 7382 else code = 8; 7383 7384 if analyzing 7385 then call add_global_ptr (code, 0, off); 7386 7387 i = 0; 7388 7389 do k = first_base to last_base; 7390 if current_ms.base_regs (k).type = 0 & ^current_ms.base_regs (k).reserved 7391 then i = k; 7392 else if current_ms.base_regs (k).type = code & current_ms.base_regs (k).offset = off 7393 then do; 7394 current_ms.base_regs (k).used = text_pos; 7395 return (bases (k)); 7396 end; 7397 end; 7398 7399 /* At this stage "i" is the free register. The following code assumes that 7400* "k" is the global register. (bug fix 82-08-16) TO. */ 7401 7402 /* Here we go through a long chain of finding potential free registers. The 7403* reason for this is that we may be within a loop and have to take one of the 7404* globally assigned registers. */ 7405 7406 k = find_global_base (code, 0, off); /* See if we are already assigned. */ 7407 if i = 0 & k = 0 7408 then do; 7409 do i = last_base to first_base by -1 while (k = 0); 7410 /* Find loc v in arg list */ 7411 7412 /* Scan order chosen to pick out globally assigned registers in order of least use. */ 7413 7414 if ^current_ms.base_regs (i).reserved & current_ms.base_regs (i).type = 2 7415 then k = i; 7416 end; 7417 7418 do i = last_base to first_base by -1 while (k = 0); 7419 /* Find link with offset v */ 7420 if ^current_ms.base_regs (i).reserved & current_ms.base_regs (i).type = 3 7421 then k = i; 7422 end; 7423 7424 do i = last_base to first_base by -1 while (k = 0); 7425 /* Find ptr at stack offset v */ 7426 if ^current_ms.base_regs (i).reserved & current_ms.base_regs (i).type = 4 7427 then k = i; 7428 end; 7429 7430 do i = last_base to first_base by -1 while (k = 0); 7431 /* Find operand spec by v */ 7432 if ^current_ms.base_regs (i).reserved & current_ms.base_regs (i).type = 7 7433 then k = i; 7434 end; 7435 7436 end; 7437 else if k = 0 7438 then k = i; /* Use global register */ 7439 7440 i = get_free_reg (current_ms.base_regs, first_base, last_base, k, k); 7441 7442 call flush_base (i); 7443 7444 unspec (inst_address) = ext_base_on; 7445 inst_address.base = base; 7446 7447 call emit_c_a ((load_base (i)), unspec (inst_address)); 7448 call emit_c_a ((add_base (i)), c_a_18 (off, 1)); 7449 7450 if current_ms.base_regs (i).type ^= code /* If we stole one */ 7451 then current_ms.base_regs (i).global = "0"b; 7452 7453 current_ms.base_regs (i).type = code; 7454 current_ms.base_regs (i).variable = 0; 7455 current_ms.base_regs (i).offset = off; 7456 current_ms.base_regs (i).used = text_pos; 7457 7458 return (bases (i)); 7459 7460 end base_man_load_large_base; 7461 7462 base_man_load_large_base_no_flush: 7463 procedure (offset, base, which) returns (bit (3) aligned); 7464 7465 /* Analogous to base_man_load_large_base, except that the 7466* register to load is specified and flush_base is not called, 7467* to avoid recursion. */ 7468 7469 dcl offset fixed binary (18); 7470 dcl base bit (3) aligned; 7471 dcl which fixed binary (3); 7472 7473 dcl 1 inst_address like node.address; 7474 7475 unspec (inst_address) = ext_base_on; 7476 inst_address.base = base; 7477 7478 call emit_c_a ((load_base (which)), unspec (inst_address)); 7479 call emit_c_a ((add_base (which)), c_a_18 ((offset), 1)); 7480 7481 if base = sp 7482 then current_ms.base_regs (which).type = 8; 7483 else current_ms.base_regs (which).type = 6; 7484 current_ms.base_regs (which).variable = 0; 7485 current_ms.base_regs (which).offset = offset; 7486 current_ms.base_regs (which).used = text_pos; 7487 7488 return (bases (which)); 7489 7490 end base_man_load_large_base_no_flush; 7491 7492 base_man_load_arg_ptr: 7493 procedure () returns (bit (3) aligned); 7494 7495 /* Loads a pointer register with a pointer to the argument list. */ 7496 7497 dcl (i, k) fixed binary (3); 7498 dcl n fixed binary (18); 7499 7500 if analyzing 7501 then call add_global_ptr (5, 0, 0); 7502 7503 k = 0; 7504 7505 do i = first_base to last_base; 7506 if current_ms.base_regs (i).type = 0 7507 then k = i; 7508 else if current_ms.base_regs (i).type = 5 7509 then do; 7510 current_ms.base_regs (i).used = text_pos; 7511 return (bases (i)); 7512 end; 7513 end; 7514 7515 i = get_free_reg (current_ms.base_regs, first_base, last_base, find_global_base (5, 0, 0), k); 7516 call flush_base (i); 7517 7518 if cs -> subprogram.subprogram_type = main_program 7519 then n = arg_ptr; 7520 else n = cs -> subprogram.entry_info + 2; 7521 7522 call emit_c_a ((load_base (i)), c_a (n, 4)); 7523 7524 current_ms.base_regs (i).type = 5; 7525 current_ms.base_regs (i).variable = 0; 7526 current_ms.base_regs (i).used = text_pos; 7527 current_ms.base_regs (i).offset = 0; 7528 7529 return (bases (i)); 7530 7531 end base_man_load_arg_ptr; 7532 7533 base_man_load_desc_ptr: 7534 procedure () returns (bit (3) aligned); 7535 7536 /* Loads a pointer register with a pointer to the argument 7537* descriptor list. */ 7538 7539 dcl (i, k) fixed binary (3); 7540 dcl n fixed binary (18); 7541 7542 if analyzing 7543 then call add_global_ptr (9, 0, 0); 7544 7545 k = 0; 7546 7547 do i = first_base to last_base; 7548 if current_ms.base_regs (i).type = 0 7549 then k = i; 7550 else if current_ms.base_regs (i).type = 9 7551 then do; 7552 current_ms.base_regs (i).used = text_pos; 7553 return (bases (i)); 7554 end; 7555 end; 7556 7557 i = get_free_reg (current_ms.base_regs, first_base, last_base, find_global_base (9, 0, 0), k); 7558 call flush_base (i); 7559 7560 if cs -> subprogram.subprogram_type = main_program 7561 then n = descriptor_ptr; 7562 else n = cs -> subprogram.entry_info + 4; 7563 7564 call emit_c_a ((load_base (i)), c_a (n, 4)); 7565 7566 current_ms.base_regs (i).type = 9; 7567 current_ms.base_regs (i).variable = 0; 7568 current_ms.base_regs (i).used = text_pos; 7569 current_ms.base_regs (i).offset = 0; 7570 7571 return (bases (i)); 7572 7573 end base_man_load_desc_ptr; 7574 7575 base_man_store_temp: 7576 procedure (temp_ptr, which); 7577 7578 /* Emits code to store a pointer temporary. Note that since 7579* this routine is called from flush_base, we must be careful 7580* to not use any pointer registers which might require flushing 7581* (to avoid recursion). */ 7582 7583 dcl (temp_ptr, tp) pointer; 7584 dcl (which, temp_reg) fixed binary (3); 7585 7586 dcl 1 inst_address like node.address; 7587 dcl (large_base_reg, i, free_reg) fixed binary (3); 7588 dcl was_reserved bit (1) aligned; 7589 7590 tp = temp_ptr; 7591 temp_reg = which; 7592 7593 unspec (inst_address) = tp -> temporary.addr_hold; 7594 inst_address.ext_base = "1"b; 7595 7596 /* If the temp is simply addressible, just store it */ 7597 7598 if ^tp -> temporary.large_address 7599 then do; 7600 call emit_c_a ((store_base (temp_reg)), unspec (inst_address)); 7601 return; 7602 end; 7603 7604 /* See if there is a pointer register which already points to 7605* the correct region for the large address. */ 7606 7607 free_reg, large_base_reg = 0; 7608 do i = first_base to last_base while (large_base_reg = 0); 7609 if current_ms.base_regs (i).type = 0 7610 then free_reg = i; 7611 else if current_ms.base_regs (i).type = 8 & current_ms.base_regs (i).offset = tp -> temporary.location 7612 then large_base_reg = i; 7613 end; 7614 7615 /* If there is no such pointer register, see if there is one 7616* globally assigned. */ 7617 7618 if large_base_reg = 0 7619 then large_base_reg = find_global_base (8, 0, (tp -> temporary.location)); 7620 7621 /* If we have found a register to use, use it. */ 7622 7623 if large_base_reg > 0 7624 then do; 7625 current_ms.base_regs (large_base_reg).used = text_pos; 7626 inst_address.base = bases (large_base_reg); 7627 call emit_c_a ((store_base (temp_reg)), unspec (inst_address)); 7628 return; 7629 end; 7630 7631 /* Try to get an empty register, or any register which does not 7632* require flushing. Avoid the register we are trying to store 7633* by pretending it is reserved for the moment. */ 7634 7635 was_reserved = current_ms.base_regs (temp_reg).reserved; 7636 current_ms.base_regs (temp_reg).reserved = "1"b; 7637 i = get_free_reg (current_ms.base_regs, first_base, last_base, 0, free_reg); 7638 current_ms.base_regs (temp_reg).reserved = was_reserved; 7639 7640 if current_ms.base_regs (i).type ^= 1 & current_ms.base_regs (i).type ^= 7 7641 then do; 7642 inst_address.base = base_man_load_large_base_no_flush ((tp -> temporary.location), sp, i); 7643 call emit_c_a ((store_base (temp_reg)), unspec (inst_address)); 7644 return; 7645 end; 7646 7647 /* Try to use pr4 as a last resort */ 7648 7649 i = which_base (4); 7650 7651 if current_ms.base_regs (i).reserved 7652 then call print_message (467); /* Sigh */ 7653 7654 inst_address.base = base_man_load_large_base_no_flush ((tp -> temporary.location), sp, i); 7655 call emit_c_a ((store_base (temp_reg)), unspec (inst_address)); 7656 7657 call emit_zero (getlp); /* Restore pr4 */ 7658 7659 end base_man_store_temp; 7660 7661 find_global_base: 7662 procedure (p_code, p_var, p_off) returns (fixed binary (3)); 7663 7664 /* Searches for base register globally assigned to code,var,off. 7665* If found, returns the register, otherwise, 0. */ 7666 7667 dcl (code, p_code) fixed binary (18), /* Type of item */ 7668 (var, p_var) fixed binary (18), /* Operand offset */ 7669 (off, p_off) fixed binary (18); /* Offset to be added to ptr */ 7670 7671 dcl i fixed binary; 7672 7673 if lp_msp ^= null 7674 then do; 7675 code = p_code; 7676 var = p_var; 7677 off = p_off; 7678 7679 do i = first_base to last_base; 7680 if loop_state.base_regs (i).type = code 7681 then if loop_state.base_regs (i).variable = var 7682 then if loop_state.base_regs (i).offset = off 7683 then if ^current_ms.base_regs (i).reserved 7684 then return (i); 7685 else call print_message (453); 7686 end; 7687 end; 7688 7689 return (0); 7690 7691 end find_global_base; 7692 7693 lock_base: 7694 procedure (reg); 7695 7696 /* Locks a base register for use in addressing */ 7697 7698 dcl reg fixed binary (3); 7699 7700 if analyzing & ^current_ms.base_regs (reg).reserved & reg >= first_base & reg <= last_base 7701 then do; 7702 ptr_data.locked = ptr_data.locked + 1; 7703 ptr_data.max_locked = max (ptr_data.max_locked, ptr_data.locked); 7704 end; 7705 7706 /* Bug 508: If pr4 found to be empty, reset it to linkage ptr */ 7707 7708 if reg = which_base (4) & current_ms.base_regs (reg).type = 0 7709 then current_ms.base_regs (reg).type = 6; /* linkage_ptr */ 7710 7711 current_ms.base_regs (reg).reserved = "1"b; 7712 7713 end lock_base; 7714 7715 base_man_dispatch: 7716 procedure (p_code, p_var, p_off) returns (bit (3) aligned); 7717 7718 /* Calls the proper base_man routine depending on args */ 7719 7720 dcl (code, p_code) fixed binary (18), 7721 (var, p_var) fixed binary (18), 7722 (off, p_off) fixed binary (18); 7723 7724 dcl base bit (3) aligned; 7725 7726 code = p_code; 7727 var = p_var; 7728 off = p_off; 7729 7730 if code = 6 | code = 8 7731 then do; 7732 if code = 6 7733 then base = lp; 7734 else base = sp; 7735 base = base_man_load_large_base (off, base); 7736 end; 7737 7738 else if code = 5 7739 then base = base_man_load_arg_ptr (); 7740 7741 else if code = 9 7742 then base = base_man_load_desc_ptr (); 7743 7744 else base = base_man_load_any_pr (code, var, off); 7745 7746 return (base); 7747 7748 end base_man_dispatch; 7749 7750 avoid_prs: 7751 procedure (p_which); 7752 7753 /* Marks the specified base registers reserved so they are not used for global items. */ 7754 7755 dcl (which, p_which) bit (6) aligned; /* "1"b for each register to avoid */ 7756 7757 dcl i fixed binary (3); 7758 7759 which = p_which; 7760 7761 do i = first_base to last_base; 7762 hold_pr_locks (i) = current_ms.base_regs (i).reserved; 7763 if substr (which, i, 1) 7764 then current_ms.base_regs (i).reserved = "1"b; 7765 end; 7766 7767 end avoid_prs; 7768 7769 restore_pr_locks: 7770 procedure (); 7771 7772 /* Restores state of base register reservations after avoid_prs */ 7773 7774 dcl i fixed binary (3); 7775 7776 do i = first_base to last_base; 7777 current_ms.base_regs (i).reserved = hold_pr_locks (i); 7778 end; 7779 7780 end restore_pr_locks; 7781 7782 add_local_ptr: 7783 procedure (); 7784 7785 /* Maintains statistics on local pointer use */ 7786 7787 ptr_data.local = ptr_data.local + 1; 7788 ptr_data.max_local = max (ptr_data.max_local, ptr_data.local); 7789 7790 end add_local_ptr; 7791 7792 add_global_ptr: 7793 procedure (code, num, offset); 7794 7795 /* Adds one to usage count of pointer node for this loop */ 7796 7797 dcl (code, num, offset) fixed binary (18); 7798 7799 dcl p pointer; 7800 7801 p = find_ptr ((code), (num), (offset)); 7802 7803 if p -> pointer.count = 0 7804 then do; 7805 if ptr_data.n_global >= hbound (ptr_data.item, 1) 7806 then do; 7807 call print_message (451, "pointer"); 7808 return; 7809 end; 7810 7811 ptr_data.n_global = ptr_data.n_global + 1; 7812 ptr_data.item (ptr_data.n_global) = p; 7813 end; 7814 7815 p -> pointer.count = p -> pointer.count + 1; 7816 7817 end add_global_ptr; 7818 7819 find_ptr: 7820 procedure (p_code, p_num, p_offset) returns (pointer); 7821 7822 /* Finds a pointer node in the hash_table. If not found, inserts it. */ 7823 7824 dcl (code, p_code) fixed binary (18), 7825 (num, p_num) fixed binary (18), 7826 (offset, p_offset) fixed binary (18); 7827 7828 dcl node_ptr pointer; 7829 dcl node_offset fixed binary (18); 7830 7831 dcl hash_index fixed binary; 7832 dcl mod_2_sum bit (36) aligned; 7833 dcl dim builtin; 7834 7835 code = p_code; 7836 num = p_num; 7837 offset = p_offset; 7838 7839 /* Form hash_index. */ 7840 7841 mod_2_sum = bool (bool (unspec (code), unspec (num), "0110"b), unspec (offset), "0110"b); 7842 hash_index = mod (binary (mod_2_sum, 35), dim (ptr_hash_table, 1)); 7843 7844 /* Search the hash table for the pointer node */ 7845 7846 do node_offset = ptr_hash_table (hash_index) repeat node_ptr -> pointer.hash_chain while (node_offset > 0); 7847 7848 node_ptr = addr (rands (node_offset)); 7849 7850 if node_ptr -> pointer.variable = num 7851 then if node_ptr -> pointer.code = code 7852 then if node_ptr -> pointer.offset = offset 7853 then return (node_ptr); 7854 end; 7855 7856 /* Create on since we didn't find one. */ 7857 7858 node_offset = create_node (pointer_node, size (pointer)); 7859 node_ptr = addr (rands (node_offset)); 7860 7861 7862 node_ptr -> pointer.code = code; 7863 node_ptr -> pointer.variable = num; 7864 node_ptr -> pointer.offset = offset; 7865 7866 /* Insert it in ptr_hash_table. */ 7867 7868 node_ptr -> pointer.hash_chain = ptr_hash_table (hash_index); 7869 ptr_hash_table (hash_index) = node_offset; 7870 7871 return (node_ptr); 7872 7873 end find_ptr; 7874 7875 /**** GET_FREE_REG ****/ 7876 7877 get_free_reg: 7878 procedure (regs, first, last, global_reg, empty_reg) returns (fixed binary (3)); 7879 7880 /* Implements register searching algorithm */ 7881 7882 dcl 1 regs (0:7) aligned like machine_state.base_regs, 7883 (first, last) fixed binary (18), /* Limits of search */ 7884 global_reg fixed binary (3), /* Register preselected because it is globally assigned to the desired item */ 7885 empty_reg fixed binary (3); /* Register preselected because it is empty */ 7886 7887 dcl (i, j, count, lused, lowest_count) fixed binary (18); 7888 7889 if global_reg > 0 7890 then return (global_reg); 7891 7892 if empty_reg > 0 7893 then if ^regs (empty_reg).reserved & ^regs (empty_reg).global 7894 then return (empty_reg); 7895 7896 j = -1; 7897 lowest_count = max_fixed_bin_18; 7898 7899 do i = first to last; 7900 if ^regs (i).reserved & ^regs (i).global 7901 then do; 7902 if regs (i).type = 0 7903 then return (i); 7904 7905 if regs (i).type = 1 7906 then count = get_usage_count (addr (rands (regs (i).variable))); 7907 else count = 1; 7908 7909 if count < lowest_count 7910 then do; 7911 lowest_count = count; 7912 lused = regs (i).used; 7913 j = i; 7914 end; 7915 7916 else if count = lowest_count 7917 then if regs (i).used < lused 7918 then do; 7919 lused = regs (i).used; 7920 j = i; 7921 end; 7922 7923 end; 7924 7925 end; 7926 7927 if j < 0 7928 then call print_message (418); 7929 else return (j); 7930 7931 end get_free_reg; 7932 7933 get_usage_count: 7934 procedure (pt) returns (fixed binary (18)); 7935 7936 /* Gets effective usage count of an operand. For temps that 7937* are offsets of array_refs, the sum of the ref_counts of all 7938* array_refs that a temp is used by is a better figure for 7939* its usage count than its ref count. */ 7940 7941 dcl (p, pt) pointer; 7942 7943 dcl (inp, o, outp) pointer; 7944 dcl count fixed binary (18); 7945 7946 p = pt; 7947 7948 if p -> node.node_type = temporary_node 7949 then do; 7950 7951 /* operand is probably variable offset of array_refs. 7952* To find real number of times needed in an xreg, get 7953* sum of ref_counts of array_refs. */ 7954 7955 if p -> temporary.start_input_to = 0 | ^p -> temporary.used_as_subscript 7956 then return (get_ref_count (p)); 7957 7958 count = 0; 7959 7960 do inp = addr (polish (p -> temporary.start_input_to)) repeat inp -> input_to.next while (inp ^= null); 7961 if inp -> input_to.which > 0 7962 then do; 7963 o = inp -> input_to.operator; 7964 if o -> operator.output > 0 7965 then do; 7966 outp = addr (rands (o -> operator.output)); 7967 count = count + get_ref_count (outp); 7968 end; 7969 end; 7970 end; 7971 7972 return (count); 7973 end; 7974 7975 else if p -> node.node_type = array_ref_node 7976 then return (get_ref_count (p)); 7977 7978 else return (1); 7979 7980 end get_usage_count; 7981 7982 /**** INDEX REGISTER MANAGEMENT ****/ 7983 7984 /* The contents of the index registers are determined by the 7985* value of the type field as follows: 7986* (v = variable field) 7987* 7988* -1 UNKNOWN 7989* 0 EMPTY 7990* 1 value v 7991* 2 constant value c 7992* */ 7993 7994 xr_man_load_any_xr: 7995 procedure (pt) returns (bit (6) aligned); 7996 7997 dcl pt pointer; /* Points at value to be loaded */ 7998 7999 dcl p pointer; 8000 dcl v fixed binary (18); 8001 dcl i fixed binary (3); 8002 dcl have_eligible bit (1) aligned; 8003 8004 p = pt; 8005 v = fixed (rel (p), 18); 8006 8007 if analyzing 8008 then do; 8009 have_eligible = eligible (p); 8010 if have_eligible 8011 then call add_global_index (p); 8012 end; 8013 8014 if p -> node.value_in.x 8015 then do; 8016 do i = first_index to last_index; 8017 if current_ms.index_regs (i).type = 1 8018 then if current_ms.index_regs (i).variable = v 8019 then do; 8020 current_ms.index_regs (i).used = text_pos; 8021 return ("001"b || bit (i, 3)); 8022 end; 8023 end; 8024 call print_message (430, v); 8025 return ("00"b3); 8026 end; 8027 8028 i = get_free_reg (current_ms.index_regs, first_index, last_index, find_global_index (v), 0); 8029 8030 call flush_xr (i); 8031 8032 call use_ind; 8033 8034 if p -> node.value_in.eaq 8035 then call emit_c_a (eax0 + i, c_a (0, 1)); 8036 8037 else do; 8038 if p -> node.not_in_storage & ^analyzing 8039 then do; 8040 call print_message (419, v); 8041 stop; 8042 end; 8043 8044 if ^p -> node.is_addressable 8045 then call m_a_except_xreg (p); 8046 8047 call emit_c_a_var (lxl0 + i, p); 8048 end; 8049 8050 current_ms.indicators_valid = i + highest_ind_state + 1; 8051 8052 call xr_man_update_xr (v, i); 8053 8054 if analyzing 8055 then if ^have_eligible 8056 then call add_local_index; 8057 8058 return ("001"b || bit (i, 3)); 8059 8060 end xr_man_load_any_xr; 8061 8062 flush_xr: 8063 procedure (which); 8064 8065 /* Empties an index register prior to reuse */ 8066 8067 dcl which fixed binary (3); /* Index reg to flush */ 8068 dcl i fixed binary (18); 8069 dcl p pointer; 8070 8071 if current_ms.index_regs (which).type ^= 1 8072 then do; 8073 if analyzing & current_ms.index_regs (which).type ^= 0 8074 then index_data.local = index_data.local - 1; 8075 return; 8076 end; 8077 8078 i = which; 8079 8080 p = addr (rands (current_ms.index_regs (i).variable)); 8081 p -> node.value_in.x = "0"b; 8082 8083 /* the value has not been previously stored, so do so */ 8084 8085 if p -> temporary.not_in_storage 8086 then call emit_temp_store (sxl0 + i, (current_ms.index_regs (i).variable)); 8087 8088 if analyzing 8089 then if ^eligible (p) 8090 then index_data.local = index_data.local - 1; 8091 8092 end flush_xr; 8093 8094 xr_man_load_const: 8095 procedure (csize) returns (bit (6) aligned); 8096 8097 /* Loads a constant into any index register */ 8098 8099 dcl csize fixed binary (18); /* Size to be loaded */ 8100 8101 dcl (i, k) fixed binary (3); 8102 dcl c fixed binary (18); 8103 8104 c = csize; 8105 8106 if const_in_xr (c, first_index, k) 8107 then do; 8108 current_ms.index_regs (k).used = text_pos; 8109 return ("001"b || bit (binary (k, 3), 3)); 8110 end; 8111 8112 i = get_free_reg (current_ms.index_regs, first_index, last_index, 0, k); 8113 8114 call flush_xr (i); 8115 8116 call use_ind; 8117 8118 call emit_c_a (eax0 + i, c_a_18 (c, 0)); 8119 8120 current_ms.indicators_valid = i + highest_ind_state + 1; 8121 8122 current_ms.index_regs (i).type = 2; 8123 current_ms.index_regs (i).variable = c; 8124 current_ms.index_regs (i).used = text_pos; 8125 8126 if analyzing 8127 then call add_local_index; 8128 8129 return ("001"b || bit (i, 3)); 8130 8131 end xr_man_load_const; 8132 8133 xr_man_update_xr: 8134 procedure (ref, ip); 8135 8136 /* Updates index register machine state */ 8137 8138 dcl ref fixed binary (18); 8139 dcl (ip, i) fixed binary (3); 8140 dcl rp pointer; 8141 8142 rp = addr (rands (ref)); 8143 i = ip; 8144 8145 if ^rp -> node.dont_update 8146 then do; 8147 current_ms.value_in_xr = "1"b; 8148 current_ms.index_regs (i).type = 1; 8149 current_ms.index_regs (i).variable = ref; 8150 rp -> node.value_in.x = "1"b; 8151 end; 8152 else current_ms.index_regs (i).type = 0; 8153 8154 current_ms.index_regs (i).used = text_pos; 8155 8156 end xr_man_update_xr; 8157 8158 const_in_xr: 8159 procedure (value, first_xr, reg) returns (bit (1) aligned); 8160 8161 /* Searches x-regs for particular const value or first empty x-reg */ 8162 8163 dcl value fixed binary (18); /* offset of const node */ 8164 dcl first_xr fixed binary (18); /* first xr to search */ 8165 dcl reg fixed binary (3); /* xr that contains const or is empty */ 8166 dcl (i, c) fixed binary (18); 8167 8168 c = value; 8169 reg = 0; 8170 8171 do i = first_xr to last_index; 8172 if current_ms.index_regs (i).type = 0 8173 then reg = i; 8174 else if current_ms.index_regs (i).type = 2 8175 then if current_ms.index_regs (i).variable = c 8176 then do; 8177 reg = i; 8178 return ("1"b); /* const in xr */ 8179 end; 8180 end; 8181 8182 return ("0"b); /* const not in xr */ 8183 8184 end const_in_xr; 8185 8186 xr_man_add_const: 8187 procedure (which, csize) returns (bit (6) aligned); 8188 8189 /* Adds a constant to the value in an index register */ 8190 8191 dcl which fixed binary (3); 8192 dcl csize fixed binary (18); 8193 8194 dcl (i, c) fixed binary (18); 8195 dcl j fixed binary (3); 8196 dcl address bit (36) aligned; 8197 8198 8199 i = which; 8200 c = csize; 8201 address = (36)"0"b; 8202 substr (address, 1, 18) = bit (c, 18); /* Set offset portion */ 8203 substr (address, 31, 6) = bit (fixed (i + 8, 6), 6); 8204 /* Set tag portion */ 8205 8206 j = get_free_reg (current_ms.index_regs, first_index, last_index, 0, 0); 8207 8208 call flush_xr (j); 8209 call use_ind (); 8210 call emit_c_a (eax0 + j, address); /* Emit eaxm_ const,n */ 8211 8212 /* Although the index register we just loaded is not really empty, 8213* we will say it is because xr_man does not have the notion 8214* of a variable plus a constant in a register. This will only work 8215* if the next instruction emitted uses the index register and 8216* does not call for some other index register to be loaded. */ 8217 8218 current_ms.indicators_valid = j + highest_ind_state + 1; 8219 8220 current_ms.index_regs (j).type = 0; /* Empty */ 8221 current_ms.index_regs (j).variable = 0; 8222 current_ms.index_regs (j).used = text_pos; 8223 8224 if analyzing 8225 then index_data.max_local = max (index_data.max_local, index_data.local + 1); 8226 8227 return (bit (fixed (j + 8, 6), 6)); /* Return XR modifier */ 8228 8229 end xr_man_add_const; 8230 8231 find_global_index: 8232 procedure (var) returns (fixed binary (3)); 8233 8234 /* Searches for a register globally assigned to var. Returns 0 if not found. */ 8235 8236 dcl (v, var) fixed binary (18); 8237 8238 dcl i fixed binary; 8239 8240 v = var; 8241 8242 if addr (rands (v)) -> node.globally_assigned 8243 then do i = first_index to last_index; 8244 if loop_state.index_regs (i).type = 1 8245 then if loop_state.index_regs (i).variable = v 8246 then if ^current_ms.index_regs (i).reserved 8247 then return (i); 8248 else call print_message (453); 8249 end; 8250 8251 return (0); 8252 8253 end find_global_index; 8254 8255 xr_man_load_xr: 8256 procedure (p_load_p, p_xr, p_update_opnd); 8257 8258 /* Loads operand into specified index register and updates 8259* machine state with another operand. */ 8260 8261 dcl (load_p, p_load_p) pointer, /* -> opnd to be loaded */ 8262 (xr, p_xr) fixed binary (3), /* Xreg to load into */ 8263 (update_opnd, p_update_opnd) fixed binary (18); /* Opnd to be added to state */ 8264 8265 dcl i fixed binary (3); 8266 dcl load_opnd fixed binary (18); 8267 8268 load_p = p_load_p; 8269 load_opnd = fixed (rel (load_p), 18); 8270 xr = p_xr; 8271 update_opnd = p_update_opnd; 8272 8273 call flush_xr (xr); 8274 8275 call use_ind; 8276 8277 if load_p -> node.value_in.x 8278 then do; 8279 i = fixed (substr (xr_man_load_any_xr (load_p), 4, 3), 3); 8280 8281 call emit_c_a (eax0 + xr, c_a_tag (i)); 8282 current_ms.indicators_valid = xr + highest_ind_state + 1; 8283 end; 8284 8285 else do; 8286 if load_p -> node.not_in_storage & ^analyzing 8287 then do; 8288 call print_message (419, load_opnd); 8289 stop; 8290 end; 8291 8292 call emit_single (lxl0 + xr, load_opnd); 8293 end; 8294 8295 call xr_man_update_xr (update_opnd, xr); 8296 8297 end xr_man_load_xr; 8298 8299 lock_index: 8300 procedure (reg); 8301 8302 /* Locks an index register for use in addressing */ 8303 8304 dcl reg fixed binary (3); 8305 8306 if analyzing & ^current_ms.index_regs (reg).reserved 8307 then do; 8308 index_data.locked = index_data.locked + 1; 8309 index_data.max_locked = max (index_data.max_locked, index_data.locked); 8310 end; 8311 8312 current_ms.index_regs (reg).reserved = "1"b; 8313 8314 end lock_index; 8315 8316 eligible: 8317 procedure (p) returns (bit (1) aligned); 8318 8319 /* Determines if an operand may be globally assigned to an 8320* index register. */ 8321 8322 dcl p pointer; /* -> operand node */ 8323 8324 dcl o pointer; 8325 8326 if p -> node.node_type = symbol_node 8327 then if p -> symbol.coordinate > 0 8328 then return (substr (cur_lp -> loop.may_keep_in_xr -> bits, p -> symbol.coordinate, 1)); 8329 else ; 8330 8331 else if p -> node.node_type = temporary_node 8332 then do; 8333 o = addr (quad (p -> temporary.output_by)); 8334 if o -> operator.coordinate > 0 8335 then return (^substr (cur_lp -> loop.computed -> obits, o -> operator.coordinate, 1)); 8336 end; 8337 8338 return ("0"b); 8339 8340 end eligible; 8341 8342 add_global_index: 8343 procedure (p); 8344 8345 /* Adds one to loop_ref_count to opnd for this loop */ 8346 8347 dcl p pointer; /* -> symbol or temporary */ 8348 8349 if p -> node.loop_ref_count = 0 8350 then do; 8351 if index_data.n_global >= hbound (index_data.item, 1) 8352 then do; 8353 call print_message (451, "index"); 8354 return; 8355 end; 8356 8357 index_data.n_global = index_data.n_global + 1; 8358 index_data.item (index_data.n_global) = p; 8359 end; 8360 8361 p -> node.loop_ref_count = p -> node.loop_ref_count + 1; 8362 8363 end add_global_index; 8364 8365 add_local_index: 8366 procedure (); 8367 8368 /* Updates local index statistics */ 8369 8370 index_data.local = index_data.local + 1; 8371 index_data.max_local = max (index_data.max_local, index_data.local); 8372 8373 end add_local_index; 8374 8375 /**** NON-ADDRESSING INDEX REGISTER OPERATIONS ****/ 8376 8377 assign_index: 8378 procedure (p_dest, p_source); 8379 8380 /* Effects an assignment via an index register. */ 8381 8382 dcl (dest, p_dest) fixed binary (18), /* destination */ 8383 (source, p_source) fixed binary (18); 8384 8385 dcl xr fixed binary (3); 8386 8387 dcl (source_p, dest_p) pointer; 8388 dcl p pointer; 8389 8390 dest = p_dest; 8391 dest_p = addr (rands (dest)); 8392 source = p_source; 8393 source_p = addr (rands (source)); 8394 8395 if string (dest_p -> symbol.value_in) 8396 then call flush_ref (dest); 8397 8398 if dest_p -> symbol.globally_assigned 8399 then do; 8400 8401 /* destination will be in an index register */ 8402 8403 xr = find_global_index (dest); 8404 8405 call xr_man_load_xr (source_p, xr, dest); 8406 8407 /* If the xr is erased in this loop, or if the variable is 8408* busy_on_exit from this loop, we must save a copy in storage. */ 8409 8410 if cur_lp -> loop.erases.xr (xr) 8411 | substr (cur_lp -> loop.busy_on_exit -> bits, dest_p -> symbol.coordinate, 1) 8412 then call emit_temp_store (sxl0 + xr, dest); 8413 end; 8414 8415 else do; 8416 8417 /* destination is not kept in an index register */ 8418 8419 xr = fixed (substr (xr_man_load_any_xr (source_p), 4, 3), 3); 8420 8421 p = find_range (dest_p, cur_lp); 8422 8423 if p = null 8424 then call emit_temp_store (sxl0 + xr, dest); 8425 8426 else if p -> range.fb18_uns 8427 then do; 8428 call emit_temp_store (stz, dest); 8429 call emit_temp_store (sxl0 + xr, dest); 8430 end; 8431 8432 else do; 8433 call use_eaq (0, Q, 0); 8434 8435 call emit_c_a (eaq, c_a_tag (xr)); 8436 call emit_c_a (qrs, c_a_18 (18, 0)); 8437 8438 current_ms.indicators_valid = Q; 8439 8440 call store (dest, in_q, 0); 8441 end; 8442 end; 8443 8444 end assign_index; 8445 8446 compare_index: 8447 procedure (p_induction_var, p_invariant); 8448 8449 /* Compares an induction variable in an index register against 8450* a loop invariant in storage */ 8451 8452 dcl (induction_var, p_induction_var) fixed binary (18), 8453 (invariant, p_invariant) fixed binary (18); 8454 8455 dcl (indp, invp) pointer; 8456 8457 dcl have_zero bit (1) aligned; 8458 dcl regno fixed binary (3); 8459 8460 induction_var = p_induction_var; 8461 indp = addr (rands (induction_var)); 8462 invariant = p_invariant; 8463 invp = addr (rands (invariant)); 8464 8465 /* Process the invariant. If it is a constant, make a new one 8466* by shifting left 18 bits. Also, find out if it is zero. 8467* Variable comparands have already been left shifted. */ 8468 8469 have_zero = "0"b; 8470 if invp -> node.node_type = constant_node 8471 then if addr (invp -> constant.value) -> int_image = 0 8472 then have_zero = "1"b; 8473 else invariant = create_constant (int_mode, substr (invp -> constant.value, 19)); 8474 8475 /* Find the register for the induction variable, and do the 8476* comparison, if necessary. */ 8477 8478 regno = fixed (substr (xr_man_load_any_xr (indp), 4, 3), 3); 8479 8480 if ^have_zero | current_ms.indicators_valid ^= regno + highest_ind_state + 1 8481 then do; 8482 call emit_single (cmpx0 + regno, invariant); 8483 8484 if have_zero 8485 then current_ms.indicators_valid = regno + highest_ind_state + 1; 8486 else current_ms.indicators_valid = 0; 8487 end; 8488 8489 end compare_index; 8490 8491 increment_index: 8492 procedure (p_induction_var, p_value, sign); 8493 8494 /* Increments an induction variable in an index register by a value */ 8495 8496 dcl (induction_var, p_induction_var) fixed binary (18), 8497 (value, p_value) fixed binary (18), 8498 sign fixed binary; 8499 8500 dcl regno fixed binary (3); 8501 8502 dcl mac fixed binary (18); 8503 8504 dcl indp pointer; 8505 8506 /* copy arguments and if the value is a constant, shift it by 18 bits */ 8507 8508 induction_var = p_induction_var; 8509 indp = addr (rands (induction_var)); 8510 8511 if addr (rands (p_value)) -> node.node_type = constant_node 8512 then value = create_constant (int_mode, substr (addr (rands (p_value)) -> constant.value, 19)); 8513 else value = p_value; 8514 8515 /* find the induction variable */ 8516 8517 regno = fixed (substr (xr_man_load_any_xr (indp), 4, 3), 3); 8518 8519 /* increment it */ 8520 8521 if sign < 0 8522 then mac = sblx0 + regno; 8523 else mac = adlx0 + regno; 8524 8525 call emit_single (mac, value); 8526 8527 /* save the result, if necessary */ 8528 8529 if cur_lp -> loop.erases.xr (regno) | substr (cur_lp -> loop.busy_on_exit -> bits, indp -> symbol.coordinate, 1) 8530 then call emit_temp_store (sxl0 + regno, induction_var); 8531 8532 end increment_index; 8533 8534 /**** GENERAL REGISTER MANAGEMENT ****/ 8535 8536 reserve_regs: 8537 procedure (what); 8538 8539 /* Reserves index and base registers */ 8540 8541 dcl (what, reserve) bit (14) aligned; /* Mask specifying which regs to reserve */ 8542 dcl i fixed binary (18); 8543 dcl j fixed binary (3); 8544 dcl length builtin; 8545 8546 reserve = what; 8547 8548 if analyzing 8549 then string (cur_lp -> loop.erases) = string (cur_lp -> loop.erases) | reserve; 8550 8551 do i = 1 to length (reserve); 8552 if substr (reserve, i, 1) 8553 then if i <= 8 8554 then do; 8555 j = i - 1; 8556 call flush_xr (j); 8557 current_ms.index_regs (j).reserved = "1"b; 8558 current_ms.index_regs (j).type = -1; 8559 /* Unknown value */ 8560 end; 8561 else do; 8562 j = i - 8; 8563 call flush_base (j); 8564 current_ms.base_regs (j).reserved = "1"b; 8565 current_ms.base_regs (j).type = -1;/* Unknown value */ 8566 current_ms.base_regs (j).variable = 0; 8567 /* debugging */ 8568 current_ms.base_regs (j).offset = 0; 8569 end; 8570 end; 8571 8572 end reserve_regs; 8573 8574 free_regs: 8575 procedure (); 8576 8577 dcl i fixed binary (18); 8578 8579 /* Frees all reserved registers (index, base, and eaq) 8580* reloading pr4 if necessary */ 8581 8582 last_pr_locked_for_pl1_ops_arg, index_data.locked, ptr_data.locked = 0; 8583 8584 current_ms.eaq (*).reserved = "0"b; 8585 8586 do i = escape_index to last_index; 8587 if current_ms.index_regs (i).reserved 8588 then do; 8589 current_ms.index_regs (i).reserved = "0"b; 8590 if current_ms.index_regs (i).type < 0 /* Unknown? */ 8591 then current_ms.index_regs (i).type = 0; 8592 end; 8593 end; 8594 8595 do i = first_base to last_base; /* Normal bases */ 8596 if current_ms.base_regs (i).reserved 8597 then do; 8598 current_ms.base_regs (i).reserved = "0"b; 8599 if current_ms.base_regs (i).type < 0 /* Unknown? */ 8600 then current_ms.base_regs (i).type = 0; 8601 end; 8602 end; 8603 8604 /* Bug 508: Reload pr4 with linkage ptr value only if necessary */ 8605 8606 i = which_base (4); 8607 if current_ms.base_regs (i).reserved & current_ms.base_regs (i).type ^= 6 8608 then do; 8609 call emit_zero (getlp); /* Emit code to restore pr4 */ 8610 current_ms.base_regs (i).type = 6; /* Linkage_ptr */ 8611 end; 8612 8613 current_ms.base_regs (i).reserved = "0"b; 8614 8615 end free_regs; 8616 8617 flush_ref: 8618 procedure (index); 8619 8620 /* Flush complex reference. This is an aliased reference. Here we find the 8621* parent header node and scan through the equivalenced list to find another 8622* node which has "value_in.eaq" set. Cause that node to be flushed too. */ 8623 8624 dcl (index, i) fixed binary (18); 8625 dcl p ptr; 8626 8627 8628 call flush_simple_ref (index); /* Flush primary */ 8629 p = addr (rands (index)); 8630 if p -> node.node_type = symbol_node 8631 then if (p -> symbol.in_equiv_stmnt) & (p -> symbol.parent ^= 0) 8632 then do; 8633 p = addr (rands (p -> symbol.parent)); /* point to list */ 8634 do i = p -> header.first_element repeat p -> symbol.next_member while (i ^= 0); 8635 p = addr (rands (i)); 8636 if p -> symbol.value_in.eaq 8637 then call flush_simple_ref (i); 8638 end; 8639 end; 8640 8641 8642 8643 flush_simple_ref: 8644 procedure (temp_index); 8645 8646 /* Removes an item from the machine state */ 8647 8648 dcl (temp, temp_index) fixed binary (18); 8649 dcl p pointer; 8650 dcl (i, r) fixed binary (18); 8651 8652 temp = temp_index; 8653 8654 p = addr (rands (temp)); 8655 8656 if p -> node.value_in.eaq 8657 then do; 8658 do r = 1 to hbound (current_ms.eaq, 1); /* A, Q, EAQ, IND */ 8659 do i = 1 by 1 while (i <= current_ms.eaq (r).number); 8660 if current_ms.eaq (r).variable (i) = temp 8661 then do; 8662 do i = i + 1 by 1 while (i <= current_ms.eaq (r).number); 8663 current_ms.eaq (r).variable (i - 1) = current_ms.eaq (r).variable (i); 8664 end; 8665 8666 current_ms.eaq (r).number = current_ms.eaq (r).number - 1; 8667 8668 /* eaq.name is not set to zero here because the jump_true and 8669* jump_false macro procedures use an if_eaq macro, which drops 8670* the reference count if the value is in the eaq, followed by an 8671* ind_jump macro which requires that eaq.name be one of the 8672* indicators substates. Since if_eaq could drop the reference 8673* count to 0, flush_ref could be called and the temporary could 8674* be removed from the machine state. However, eaq.name must be 8675* preserved for subsequent use by ind_jump. */ 8676 8677 end; 8678 end; 8679 end; 8680 end; 8681 8682 if p -> node.value_in.x 8683 then do i = first_index repeat i + 1 while (i <= last_index); 8684 if current_ms.index_regs (i).type = 1 8685 then if current_ms.index_regs (i).variable = temp 8686 then do; 8687 current_ms.index_regs (i).type = 0; 8688 if analyzing 8689 then if ^eligible (p) 8690 then index_data.local = index_data.local - 1; 8691 end; 8692 end; 8693 8694 string (p -> node.value_in) = "0"b; 8695 8696 end flush_simple_ref; 8697 end flush_ref; 8698 8699 flush_addr: 8700 procedure (temp_index); 8701 8702 /* Removes the address of an item from the machine state */ 8703 8704 dcl (temp, temp_index) fixed binary (18); 8705 dcl p pointer; 8706 dcl i fixed binary (18); 8707 8708 temp = temp_index; 8709 p = addr (rands (temp)); 8710 8711 if p -> node.address_in_base 8712 then do; 8713 do i = first_base repeat i + 1 while (i <= last_base); 8714 if current_ms.base_regs (i).type = 1 8715 then if current_ms.base_regs (i).variable = temp 8716 then do; 8717 current_ms.base_regs (i).type = 0; 8718 if analyzing 8719 then do; 8720 ptr_data.local = ptr_data.local - 1; 8721 if p -> node.data_type = char_mode & p -> node.units ^= char_units 8722 then do; 8723 8724 /* Restore address of aligned character string */ 8725 8726 substr (unspec (p -> node.address), 1, 18) = p -> node.addr_hold; 8727 p -> node.reloc = p -> node.reloc_hold; 8728 end; 8729 end; 8730 end; 8731 end; 8732 p -> node.address_in_base = "0"b; 8733 end; 8734 8735 end flush_addr; 8736 8737 lock_tag_register: 8738 procedure (tag); 8739 8740 /* Reserves the register specified by the address tag */ 8741 8742 dcl (tag, t) bit (6) aligned; 8743 8744 t = tag; 8745 8746 if substr (t, 3, 1) /* XR modification */ 8747 then call lock_index (fixed (t, 6) - 8); 8748 else if t = QL_mod 8749 then call lock_eaq (Q); 8750 else if t = AL_mod 8751 then call lock_eaq (A); 8752 8753 end lock_tag_register; 8754 8755 /**** EAQ MANAGEMENT ****/ 8756 8757 eaq_man_load_a_or_q: 8758 procedure (pt) returns (bit (6) aligned); 8759 8760 /* Loads an integer value into the A or Q. */ 8761 8762 dcl (pt, p) pointer; 8763 dcl v fixed binary (18); 8764 dcl name fixed binary (18); 8765 8766 p = pt; 8767 v = fixed (rel (p), 18); 8768 8769 /* If the operand is already in the A or Q, no need to load it */ 8770 8771 if p -> node.value_in.eaq 8772 then do; 8773 name = get_eaq_name (v); 8774 if name = in_q 8775 then return (QL_mod); 8776 else if name = in_ia 8777 then return (AL_mod); 8778 end; 8779 8780 /* Must load the operand. If one of the A or Q is reserved, we must 8781* load the other one. If neither is reserved, we favor the Q. */ 8782 8783 if current_ms.eaq (A).reserved & current_ms.eaq (Q).reserved 8784 then call print_message (449); /* Oops */ 8785 8786 if current_ms.eaq (A).reserved 8787 then name = in_q; 8788 else if current_ms.eaq (Q).reserved 8789 then name = in_ia; 8790 else if current_ms.eaq (Q).number > 0 & current_ms.eaq (A).number = 0 & current_ms.eaq (IND).number = 0 8791 then name = in_ia; 8792 else name = in_q; 8793 8794 call use_eaq (v, name, 0); 8795 8796 if ^p -> node.is_addressable 8797 then call m_a_except_xreg (p); 8798 8799 call emit_c_a_var (load_inst (name), p); 8800 8801 current_ms.indicators_valid = eaq_name_to_reg (name); 8802 8803 call in_reg (v, name); 8804 8805 if name = in_q 8806 then return (QL_mod); 8807 else return (AL_mod); 8808 8809 end eaq_man_load_a_or_q; 8810 8811 get_eaq_name: 8812 procedure (opnd) returns (fixed binary (18)); 8813 8814 /* Search the eaq state for opnd and return its eaq name */ 8815 8816 dcl (op, opnd) fixed binary (18); 8817 dcl (r, v) fixed binary (18); 8818 8819 op = opnd; 8820 8821 if ^addr (rands (op)) -> node.value_in.eaq 8822 then return (0); /* Don't even look */ 8823 8824 do r = 1 to hbound (current_ms.eaq, 1); 8825 8826 do v = 1 to current_ms.eaq (r).number; 8827 8828 if current_ms.eaq (r).variable (v) = op 8829 then return (current_ms.eaq (r).name); 8830 8831 end; 8832 8833 end; 8834 8835 /* If we get here, the node has value_in.eaq on but the operand 8836* is not in the eaq. */ 8837 8838 call print_message (450); 8839 return (0); 8840 8841 end get_eaq_name; 8842 8843 in_reg: 8844 procedure (v, name); 8845 8846 /* Puts an operand in an eaq register */ 8847 8848 dcl (var, v) fixed binary (18), 8849 name fixed binary (18), 8850 (i, n, regno) fixed binary (18); 8851 8852 var = v; 8853 8854 if addr (rands (var)) -> node.dont_update 8855 then return; 8856 8857 regno = eaq_name_to_reg (name); 8858 8859 if current_ms.eaq (regno).name > 0 & current_ms.eaq (regno).name ^= name 8860 then call use_eaq (0, (regno), 0); 8861 8862 current_ms.eaq (regno).name = name; 8863 8864 if name = in_ind 8865 then do; 8866 call print_message (420, var); 8867 return; 8868 end; 8869 8870 addr (rands (var)) -> node.value_in.eaq = "1"b; 8871 8872 if current_ms.eaq (regno).number < hbound (current_ms.eaq.variable, 2) 8873 then do; 8874 n, current_ms.eaq (regno).number = current_ms.eaq (regno).number + 1; 8875 current_ms.eaq (regno).variable (n) = var; 8876 return; 8877 end; 8878 8879 do i = 1 to hbound (current_ms.eaq.variable, 2); /* Guaranteed to be an opening */ 8880 8881 if addr (rands (current_ms.eaq (regno).variable (i))) -> node.node_type ^= temporary_node 8882 then do; 8883 addr (rands (current_ms.eaq (regno).variable (i))) -> node.value_in.eaq = "0"b; 8884 current_ms.eaq (regno).variable (i) = var; 8885 return; 8886 end; 8887 end; 8888 8889 call print_message (448); 8890 8891 end in_reg; 8892 8893 use_eaq: 8894 procedure (array_sym, reg_number, protect_ind); 8895 8896 /* Stores values of all temps currently in eaq and required later on. 8897* The eaq is then emptied. */ 8898 8899 dcl array_sym fixed binary (18); 8900 dcl reg_number fixed binary (18); 8901 dcl protect_ind fixed binary (18); 8902 8903 call save_eaq_temps ((array_sym), (reg_number), (protect_ind)); 8904 call reset_eaq ((reg_number)); 8905 8906 end use_eaq; 8907 8908 save_eaq_temps: 8909 procedure (array_sym, reg_no, protect_ind); 8910 8911 /* Stores temp values for all temps currently in eaq and required later on. 8912* Subscript values can be stored in an index reg or not stored at all. 8913* All others are stored in storage. The machine state is not directly affected. */ 8914 8915 dcl array_sym fixed binary (18); /* zero or sym offset of sym changing eaq state. */ 8916 dcl reg_no fixed binary (18); /* eaq register */ 8917 dcl protect_ind fixed binary (18); /* if ^= 0 then protect ind state while storing temps */ 8918 8919 dcl asp pointer; /* null or -> node changing eaq state. */ 8920 8921 if array_sym > 0 8922 then asp = addr (rands (array_sym)); 8923 else asp = null; 8924 8925 if current_ms.eaq (IND).number > 0 & protect_ind = 0 8926 then call use_ind (); 8927 8928 if reg_no ^= IND 8929 then call save (EAQ); /* Only IND does not affect EAQ */ 8930 8931 if reg_no = EAQ 8932 then do; /* EAQ affects both A and Q */ 8933 call save (A); 8934 call save (Q); 8935 end; 8936 else call save ((reg_no)); 8937 8938 return; 8939 8940 save: 8941 procedure (reg); 8942 8943 /* Internal procedure of save_eaq_temps. Saves temps in 8944* one of the eaq registers. */ 8945 8946 dcl (reg, r) fixed binary (18); 8947 dcl bit6 bit (6) aligned; 8948 dcl i fixed binary (18); 8949 dcl own_sub pointer; 8950 dcl p pointer; 8951 dcl saved_state fixed binary (18); 8952 dcl st_inst fixed binary (18); 8953 8954 /* If symbol causing eaq state change is an array ref node, the value in the 8955* eaq is the value of the subscript, and this is the last reference for 8956* this value, then we don't have to store the value anywhere. */ 8957 8958 r = reg; 8959 8960 if current_ms.eaq (r).number = 0 8961 then return; 8962 8963 own_sub = null (); 8964 saved_state = 0; 8965 8966 if r = Q /* Subscripts can only be in the Q */ 8967 then if array_sym > 0 8968 then if asp -> node.node_type = array_ref_node 8969 then if asp -> array_ref.variable_offset 8970 then if get_ref_count (asp) = 1 8971 then if addr (rands (asp -> array_ref.v_offset)) -> node.value_in.eaq 8972 then own_sub = addr (rands (asp -> array_ref.v_offset)); 8973 8974 if ^do_rounding | current_ms.rounded 8975 then st_inst = store_no_round_inst (current_ms.eaq (r).name); 8976 else st_inst = store_inst (current_ms.eaq (r).name); 8977 8978 do i = 1 by 1 while (i <= current_ms.eaq (r).number); 8979 8980 p = addr (rands (current_ms.eaq (r).variable (i))); 8981 8982 if p -> node.not_in_storage & ^p -> node.value_in.x 8983 then do; 8984 if p -> temporary.used_as_subscript 8985 then if p = own_sub & get_ref_count (p) = 1 8986 then ; 8987 else do; 8988 if protect_ind ^= 0 & saved_state = 0 8989 then call save_ind_state (saved_state); 8990 bit6 = xr_man_load_any_xr (p); 8991 end; 8992 8993 else call emit_temp_store (st_inst, (current_ms.eaq (r).variable (i))); 8994 end; 8995 8996 end; 8997 8998 if saved_state ^= 0 8999 then call restore_ind_state (saved_state); 9000 9001 end save; 9002 9003 end save_eaq_temps; 9004 9005 use_ind: 9006 procedure (); 9007 9008 /* If the indicators contain a logical value, it is saved 9009* in the a. Then the indicators are set invalid. */ 9010 9011 call move_logical_to_a (); 9012 current_ms.indicators_valid = 0; 9013 9014 end use_ind; 9015 9016 move_logical_to_a: 9017 procedure (); 9018 9019 /* Moves logical value from indicators to A-reg if the value needs to be stored */ 9020 9021 dcl p pointer; 9022 dcl var fixed binary (18); 9023 9024 if current_ms.eaq (IND).name > in_ind 9025 then if current_ms.eaq (IND).number > 0 9026 then do; 9027 p = addr (rands (current_ms.eaq (IND).variable (1))); 9028 if p -> node.node_type = temporary_node 9029 then do; 9030 call save_logical_temps (); 9031 call emit_zero ((ind_to_a (current_ms.eaq (IND).name - in_ind))); 9032 9033 /* Update machine state */ 9034 9035 var = current_ms.eaq (IND).variable (1); 9036 call reset_eaq (IND); 9037 current_ms.eaq (A).number = 1; 9038 current_ms.eaq (A).name = in_a; 9039 current_ms.eaq (A).variable (1) = var; 9040 p -> node.value_in.eaq = "1"b; 9041 current_ms.indicators_valid = A; 9042 9043 end; 9044 9045 end; 9046 9047 save_logical_temps: 9048 procedure (); 9049 9050 /* This procedure is analogous to save_eaq_temps, but is used 9051* to save temps in the A register only. It is called by 9052* move_logical_to_a to avoid recursion. */ 9053 9054 dcl i fixed binary (18); 9055 dcl p ptr; 9056 dcl saved_state fixed bin (18); 9057 dcl bit6 bit (6) aligned; 9058 dcl st_inst fixed bin (18); 9059 9060 do i = 1 by 1 while (i <= current_ms.eaq (A).number); 9061 if addr (rands (current_ms.eaq (A).variable (i))) -> node.not_in_storage 9062 then call emit_temp_store (sta, (current_ms.eaq (A).variable (i))); 9063 end; 9064 9065 if current_ms.eaq (EAQ).number > 0 9066 then do; 9067 saved_state = 0; 9068 if ^do_rounding | current_ms.rounded 9069 then st_inst = store_no_round_inst (current_ms.eaq (EAQ).name); 9070 else st_inst = store_inst (current_ms.eaq (EAQ).name); 9071 9072 do i = 1 to current_ms.eaq (EAQ).number; 9073 p = addr (rands (current_ms.eaq (EAQ).variable (i))); 9074 9075 if p -> node.not_in_storage & ^p -> node.value_in.x 9076 then do; 9077 if p -> temporary.used_as_subscript 9078 then do; 9079 call save_ind_state (saved_state); 9080 bit6 = xr_man_load_any_xr (p); 9081 end; 9082 9083 else call emit_temp_store (st_inst, (current_ms.eaq (EAQ).variable (i))); 9084 end; 9085 9086 end; 9087 9088 if saved_state ^= 0 9089 then call restore_ind_state (saved_state); 9090 end; 9091 9092 call reset_eaq (A); 9093 9094 end save_logical_temps; 9095 end move_logical_to_a; 9096 9097 flush_eaq: 9098 procedure (); 9099 9100 /* Flushes eaq without moving temps to x-regs */ 9101 9102 dcl r fixed binary (18); 9103 dcl i fixed binary (18); 9104 dcl p pointer; 9105 dcl st_inst fixed binary (18); 9106 9107 if current_ms.eaq (IND).number > 0 9108 then call use_ind (); 9109 9110 do r = 1 to 3; /* A, Q, EAQ */ 9111 9112 if current_ms.eaq (r).number > 0 9113 then do; 9114 9115 if ^do_rounding | current_ms.rounded 9116 then st_inst = store_no_round_inst (current_ms.eaq (r).name); 9117 else st_inst = store_inst (current_ms.eaq (r).name); 9118 9119 do i = 1 to current_ms.eaq (r).number; 9120 9121 p = addr (rands (current_ms.eaq (r).variable (i))); 9122 9123 if p -> node.node_type = temporary_node 9124 then if p -> temporary.not_in_storage 9125 then if get_ref_count (p) > 0 9126 then call emit_temp_store (st_inst, (current_ms.eaq (r).variable (i))); 9127 9128 p -> node.value_in.eaq = "0"b; /* no longer in eaq */ 9129 end; 9130 9131 current_ms.eaq (r).name = 0; 9132 current_ms.eaq (r).number = 0; 9133 9134 end; 9135 9136 end; 9137 9138 current_ms.rounded = "0"b; 9139 9140 end flush_eaq; 9141 9142 load: 9143 procedure (vp, name); 9144 9145 /* Loads an operand into an eaq register */ 9146 9147 dcl vp fixed binary (18), /* operand to be loaded */ 9148 name fixed binary (18); /* eaq_name to be loaded */ 9149 dcl (var, eaq_name, regno, i) fixed binary (18); 9150 9151 eaq_name = name; 9152 9153 if eaq_name <= 0 | eaq_name > in_ind 9154 then do; 9155 call print_message (421, vp); 9156 return; 9157 end; 9158 9159 var = vp; 9160 9161 /* If this load would destroy the A, and if there are 9162* logical values in the indicators, we must get the 9163* indicators into the A now, before the load takes place. 9164* Otherwise, a subsequent call to use_ind could 9165* destroy the load. This is a kludge. */ 9166 9167 if eaq_name_to_reg (eaq_name) ^= Q & current_ms.eaq (IND).number > 0 9168 then call move_logical_to_a (); 9169 9170 if addr (rands (var)) -> node.value_in.eaq 9171 then do; 9172 9173 /* Search the machine state; the operand may already be 9174* in the desired register */ 9175 9176 do regno = 1 to hbound (current_ms.eaq, 1); /* A, Q, EAQ, IND */ 9177 9178 do i = 1 by 1 while (i <= current_ms.eaq (regno).number); 9179 9180 if var = current_ms.eaq (regno).variable (i) 9181 then do; 9182 9183 if eaq_name = in_tq | eaq_name = in_q 9184 then if current_ms.eaq (regno).name = in_tq | current_ms.eaq (regno).name = in_q 9185 then current_ms.eaq (regno).name = eaq_name; 9186 9187 if eaq_name = current_ms.eaq (regno).name 9188 then do; 9189 call drop_count (var, 1); 9190 return; 9191 end; 9192 9193 if eaq_name = in_ind 9194 then do; 9195 if regno = IND 9196 then do; 9197 call drop_count (var, 1); 9198 return; 9199 end; 9200 9201 if current_ms.eaq (regno).name = in_a 9202 then if current_ms.indicators_valid = A 9203 then do; 9204 call flush_ref (var); 9205 if current_ms.eaq (A).number = 0 9206 then current_ms.eaq (A).name = 0; 9207 call in_reg (var, tnz); 9208 /* Put it in INDs */ 9209 call drop_count (var, 1); 9210 return; 9211 end; 9212 9213 end; 9214 9215 else if eaq_name = in_a & regno = IND 9216 & addr (rands (var)) -> node.node_type = temporary_node 9217 then do; 9218 call move_logical_to_a (); 9219 call drop_count (var, 1); 9220 return; 9221 end; 9222 9223 end; 9224 9225 end; 9226 9227 end; 9228 9229 end; 9230 9231 call emit_single ((load_inst (eaq_name)), var); 9232 9233 if eaq_name = in_ind 9234 then eaq_name = tnz; 9235 9236 call in_reg (var, eaq_name); 9237 9238 current_ms.rounded = "1"b; 9239 9240 end load; 9241 9242 check_zero: 9243 procedure (opnd) returns (bit (1) aligned); 9244 9245 /* Returns true if operand is "zero value" for its data type */ 9246 9247 dcl opnd fixed binary (18); 9248 9249 if opnd < 0 /* a count */ 9250 then return (opnd = -bias); 9251 9252 if addr (rands (opnd)) -> node.node_type = constant_node 9253 then return (opnd = zero_for_dt (addr (rands (opnd)) -> constant.data_type)); 9254 else return ("0"b); 9255 9256 end check_zero; 9257 9258 check_negative: 9259 procedure (opnd) returns (bit (1) aligned); 9260 9261 /* return true if operand is "negative" for its data type */ 9262 9263 dcl opnd fixed bin (18); 9264 dcl (p, val_ptr) ptr; 9265 dcl based_integer fixed bin (35) aligned based; 9266 dcl based_real float bin (27) aligned based; 9267 dcl 1 based_double aligned based, 9268 2 based_dp float bin (63) unaligned; 9269 9270 if opnd < 0 /* a count */ 9271 then return (opnd < -bias); 9272 9273 p = addr (rands (opnd)); 9274 if p -> node.data_type < 1 | p -> node.data_type > 4 9275 then return ("0"b); /* cannot be neg if not numeric */ 9276 val_ptr = addr (p -> constant.value); 9277 goto return_neg (p -> node.data_type); 9278 9279 return_neg (1): /* INTEGER */ 9280 return (val_ptr -> based_integer < 0); 9281 9282 return_neg (2): /* REAL */ 9283 return_neg (4): /* COMPLEX */ 9284 return (val_ptr -> based_real < 0.0); 9285 9286 return_neg (3): /* DOUBLE PRECISION */ 9287 return (val_ptr -> based_dp < 0.0); 9288 9289 end check_negative; 9290 9291 reset_eaq: 9292 procedure (reg_number); 9293 9294 /* Resets the specified eaq register to the empty state */ 9295 9296 dcl reg_number fixed binary (18); 9297 9298 if reg_number ^= IND 9299 then call reset (EAQ); /* Only IND does not affect EAQ */ 9300 9301 if reg_number = EAQ 9302 then do; /* EAQ affects both A and Q */ 9303 call reset (A); 9304 call reset (Q); 9305 end; 9306 else call reset (reg_number); 9307 9308 current_ms.rounded = "0"b; 9309 9310 return; 9311 9312 reset: 9313 procedure (r); 9314 9315 /* Resets a single eaq register */ 9316 9317 dcl (i, r, regno) fixed binary (18); 9318 9319 regno = r; 9320 9321 do i = 1 by 1 while (i <= current_ms.eaq (regno).number); 9322 addr (rands (current_ms.eaq (regno).variable (i))) -> node.value_in.eaq = "0"b; 9323 end; 9324 9325 current_ms.eaq (regno).number = 0; 9326 current_ms.eaq (regno).name = 0; 9327 9328 end reset; 9329 9330 end reset_eaq; 9331 9332 store: 9333 procedure (vp, name, update_flag); 9334 9335 dcl vp fixed binary (18); /* Operand to be stored */ 9336 dcl name fixed binary (18); /* Eaq_name from which storing takes place */ 9337 dcl update_flag fixed binary (18); /* =0 if store should update ms */ 9338 9339 dcl (var, eaq_name, inst_number) fixed binary (18); 9340 dcl v pointer; 9341 9342 eaq_name = name; 9343 var = vp; 9344 v = addr (rands (var)); 9345 9346 if do_rounding & ^current_ms.rounded 9347 then inst_number = store_inst (eaq_name); 9348 else inst_number = store_no_round_inst (eaq_name); 9349 9350 if v -> node.node_type = temporary_node 9351 then call bump_count (var, 1); 9352 9353 call emit_single (inst_number, var); 9354 9355 if eaq_name = in_q 9356 then if string (v -> node.value_in) 9357 then call flush_ref (var); 9358 9359 if update_flag = 0 9360 then do; 9361 v -> node.not_in_storage = "0"b; 9362 call in_reg (var, eaq_name); 9363 end; 9364 9365 end store; 9366 9367 lock_eaq: 9368 procedure (reg); 9369 9370 /* Locks an EAQ register for use in addressing */ 9371 9372 dcl reg fixed binary (18); 9373 9374 current_ms.eaq (reg).reserved = "1"b; 9375 9376 end lock_eaq; 9377 9378 /**** INDICATOR SAVING AND RESTORING ****/ 9379 9380 save_ind_state: 9381 procedure (a_state); 9382 9383 /* Saves (and restores) indicator state if compiler must emit 9384* instructions that modify the indicators. */ 9385 9386 dcl a_state fixed binary (18); /* output - see below */ 9387 dcl saved_state fixed binary (18); 9388 9389 /* The parameter a_state is set as follows to indicate how the 9390* indicators should be restored: 9391* = 0: the indicators are meaningless, or the reg is empty; 9392* the indicators need not be restored. 9393* > 0: the indicators contain a logical value which was stored; 9394* the indicators can be reloaded directly. 9395* < 0: the indicators reflect the sign of a register; 9396* the indicators can be restored with a comparison against 0. */ 9397 9398 dcl escape_address bit (36) aligned internal static options (constant) initial ("600056000100"b3); 9399 /* address of sp|46 */ 9400 9401 if current_ms.indicators_valid > 0 & current_ms.eaq (IND).name = 0 9402 then if current_ms.indicators_valid <= highest_ind_state 9403 then saved_state = -current_ms.eaq (current_ms.indicators_valid).name; 9404 else if current_ms.index_regs (current_ms.indicators_valid - highest_ind_state - 1).type > 0 9405 then saved_state = -current_ms.indicators_valid; 9406 else saved_state = 0; 9407 else if current_ms.eaq (IND).name >= in_ind 9408 then do; /* logical value */ 9409 saved_state = current_ms.eaq (IND).name; 9410 if current_ms.eaq (IND).name > in_ind 9411 then current_ms.eaq (IND).name = in_ind; 9412 call emit_c_a (store_ind, escape_address); 9413 end; 9414 else saved_state = 0; 9415 9416 a_state = saved_state; 9417 return; 9418 9419 restore_ind_state: 9420 entry (a_state); 9421 9422 saved_state = a_state; 9423 9424 if saved_state < 0 9425 then do; /* inds reflect sign of reg, compare to zero */ 9426 saved_state = -saved_state; 9427 9428 if saved_state <= highest_ind_state 9429 then do; 9430 call emit_c_a_const ((compare_inst (saved_state)), (zero_for_dt (dt_from_reg (saved_state)))); 9431 current_ms.indicators_valid = eaq_name_to_reg (saved_state); 9432 end; 9433 9434 else do; 9435 call emit_c_a_const (cmpx0 + saved_state - highest_ind_state - 1, (zero_for_dt (int_mode))); 9436 saved_state = 0; 9437 end; 9438 end; 9439 9440 else if saved_state > 0 9441 then call emit_c_a (load_ind, escape_address); /* ind state was stored, load it back */ 9442 9443 if saved_state > in_ind 9444 then current_ms.eaq (IND).name = saved_state; 9445 9446 end save_ind_state; 9447 9448 /**** STATE MANAGEMENT ****/ 9449 9450 save_state: 9451 procedure (lbl); 9452 9453 /* Given a label operand, merge the current ms into the label's statement's machine state */ 9454 9455 dcl (lbl, msp, stmnt) fixed binary (18); 9456 dcl msp_ptr pointer; 9457 9458 stmnt = addr (rands (lbl)) -> label.statement; 9459 if stmnt > 0 9460 then do; 9461 msp = addr (quad (stmnt)) -> opt_statement.machine_state; 9462 if msp = 0 9463 then do; /* No previous ms for statement */ 9464 9465 /* reuse an old machine_state node or allocate a new one */ 9466 9467 if next_free_ms = null 9468 then do; 9469 msp = create_node (machine_state_node, size (machine_state)); 9470 msp_ptr = addr (rands (msp)); 9471 end; 9472 9473 else do; 9474 msp_ptr = next_free_ms; 9475 msp = fixed (rel (msp_ptr), 18); 9476 next_free_ms = msp_ptr -> machine_state.next; 9477 unspec (msp_ptr -> machine_state) = "0"b; 9478 msp_ptr -> machine_state.node_type = machine_state_node; 9479 end; 9480 9481 msp_ptr -> machine_state.next = null; 9482 addr (quad (stmnt)) -> opt_statement.machine_state = msp; 9483 9484 /* if machine state exists, copy to target; empty state is initial value for node */ 9485 9486 if ^state_discarded 9487 then do; 9488 call bump_all_ms_ref_counts; /* mark everything in ms as saved */ 9489 msp_ptr -> machine_state.ms = current_ms.ms; 9490 /* copy ms to target label ms */ 9491 end; 9492 end; 9493 else do; /* Machine state exists, merge them. */ 9494 msp_ptr = addr (rands (msp)); 9495 9496 if state_discarded 9497 then do; 9498 call drop_all_ms_ref_counts (msp_ptr -> machine_state); 9499 /* all are unsaved */ 9500 unspec (msp_ptr -> machine_state.ms) = "0"b; 9501 /* empty state */ 9502 end; 9503 else call merge_state (msp_ptr -> machine_state, current_ms, "0"b); 9504 end; 9505 end; 9506 9507 end save_state; 9508 9509 merge_state: 9510 procedure (existing_state, a_new_state, update_flag); 9511 9512 /* Merge new_state into existing_state. */ 9513 9514 dcl 1 (existing_state, a_new_state, new_state) like machine_state aligned; 9515 dcl (update_flag, updating_ms) bit (1) aligned; 9516 dcl (i, j, r) fixed binary (18); 9517 dcl reg fixed binary (3); 9518 9519 new_state = a_new_state; 9520 updating_ms = update_flag; /* ="1"b if merging into current state. */ 9521 9522 if updating_ms /* Merging states at a label, ms is freed when done. */ 9523 then do; 9524 new_state.next = next_free_ms; 9525 next_free_ms = addr (a_new_state); 9526 call drop_all_ms_ref_counts (new_state); 9527 end; 9528 9529 if state_discarded & updating_ms /* make the current machine state be new_state */ 9530 then do; 9531 existing_state.ms = new_state.ms; /* note this assignment destroys **.global */ 9532 9533 do r = 1 to hbound (current_ms.eaq, 1); /* A, Q, EAQ, IND */ 9534 do i = 1 to new_state.eaq (r).number; 9535 addr (rands (new_state.eaq (r).variable (i))) -> node.value_in.eaq = "1"b; 9536 end; 9537 end; 9538 9539 if new_state.value_in_xr 9540 then do i = first_index to last_index; 9541 existing_state.index_regs (i).global = "0"b; 9542 /* invalid anyhow */ 9543 if new_state.index_regs (i).type = 1 9544 then if new_state.index_regs (i).variable ^= 0 9545 then do; 9546 addr (rands (new_state.index_regs (i).variable)) -> node.value_in.x = "1"b; 9547 if analyzing 9548 then if ^eligible (addr (rands (new_state.index_regs (i).variable))) 9549 then index_data.local = index_data.local + 1; 9550 end; 9551 else ; 9552 else if new_state.index_regs (i).type ^= 0 9553 then index_data.local = index_data.local + 1; 9554 end; 9555 9556 if new_state.address_in_base 9557 then do i = first_base to last_base; 9558 existing_state.base_regs (i).global = "0"b; 9559 /* invalid anyhow */ 9560 if new_state.base_regs (i).type = 1 9561 then if new_state.base_regs (i).variable ^= 0 9562 then do; 9563 j = new_state.base_regs (i).variable; 9564 addr (rands (j)) -> node.addr_hold = 9565 substr (unspec (addr (rands (j)) -> node.address), 1, 18); 9566 addr (rands (j)) -> node.reloc_hold = addr (rands (j)) -> node.reloc; 9567 addr (rands (j)) -> node.address.base = bases (i); 9568 addr (rands (j)) -> node.address.offset = 0; 9569 addr (rands (j)) -> node.address.tag = "0"b; 9570 addr (rands (j)) -> node.reloc = rc_a; 9571 addr (rands (j)) -> node.address_in_base = "1"b; 9572 ptr_data.local = ptr_data.local + 1; 9573 end; 9574 else ; 9575 else if new_state.base_regs (i).type = 7 9576 then ptr_data.local = ptr_data.local + 1; 9577 end; 9578 9579 /* Because the global bits have been wiped out by the structure 9580* assignment to existing_state.ms, we refresh them by calling 9581* refresh_global_bits. */ 9582 9583 call refresh_global_bits (cur_lp); 9584 9585 return; 9586 end; 9587 9588 /* Form intersection of EAQ states. */ 9589 9590 do r = 1 to hbound (current_ms.eaq, 1); /* A, Q, EAQ, IND */ 9591 9592 if existing_state.eaq (r).number = 0 | new_state.eaq (r).number = 0 9593 then call empty_the_eaq (r); 9594 9595 else if existing_state.eaq (r).name ^= new_state.eaq (r).name 9596 then call empty_the_eaq (r); 9597 9598 else do; /* Form intersection */ 9599 9600 i = 1; 9601 do while (i <= existing_state.eaq (r).number); 9602 9603 do j = 1 to new_state.eaq (r).number 9604 while (existing_state.eaq (r).variable (i) ^= new_state.eaq (r).variable (j)); 9605 end; 9606 9607 if j > new_state.eaq (r).number 9608 then do; /* no match */ 9609 9610 if updating_ms 9611 then addr (rands (existing_state.eaq (r).variable (i))) -> node.value_in.eaq = "0"b; 9612 else call drop_ms_ref_count (addr (rands (existing_state.eaq (r).variable (i))), ("0"b)); 9613 9614 /* remove item from eaq variable list */ 9615 9616 do j = i to existing_state.eaq (r).number - 1; 9617 existing_state.eaq (r).variable (j) = existing_state.eaq (r).variable (j + 1); 9618 end; 9619 9620 existing_state.eaq (r).number = existing_state.eaq (r).number - 1; 9621 9622 end; 9623 9624 else i = i + 1; /* matched, proceed */ 9625 9626 end; /* end intersection loop */ 9627 9628 if existing_state.eaq (r).number = 0 9629 then existing_state.eaq (r).name = 0; 9630 9631 end; /* end intersection code */ 9632 9633 end; /* end loop over eaq registers */ 9634 9635 /* Form intersection of rounded states. */ 9636 9637 existing_state.rounded = existing_state.rounded & new_state.rounded; 9638 9639 /* Form intersection of indicator states. */ 9640 9641 if existing_state.indicators_valid ^= new_state.indicators_valid 9642 then existing_state.indicators_valid = 0; 9643 9644 /* Form intersection of index regs states. */ 9645 9646 do reg = lbound (current_ms.index_regs, 1) to hbound (current_ms.index_regs, 1); 9647 9648 if existing_state.index_regs (reg).type = new_state.index_regs (reg).type 9649 then if existing_state.index_regs (reg).variable ^= new_state.index_regs (reg).variable 9650 then call empty_xr; /* Implied argument is "reg" */ 9651 else ; /* index reg the same in both states */ 9652 else call empty_xr; /* not the same, flush the reg */ 9653 end; 9654 9655 if ^new_state.value_in_xr 9656 then existing_state.value_in_xr = "0"b; 9657 9658 /* Form intersection of base regs states. */ 9659 9660 do reg = lbound (current_ms.base_regs, 1) to hbound (current_ms.base_regs, 1); 9661 9662 if existing_state.base_regs (reg).type ^= new_state.base_regs (reg).type 9663 | existing_state.base_regs (reg).variable ^= new_state.base_regs (reg).variable 9664 | existing_state.base_regs (reg).offset ^= new_state.base_regs (reg).offset 9665 then call empty_base; /* implied arg is reg */ 9666 9667 end; 9668 9669 if ^new_state.address_in_base 9670 then existing_state.address_in_base = "0"b; 9671 9672 /* Form intersection of dynamic temp states */ 9673 9674 if existing_state.stack_extended ^= new_state.stack_extended 9675 then existing_state.stack_extended = "1"b; 9676 9677 if existing_state.last_dynamic_temp ^= new_state.last_dynamic_temp 9678 then existing_state.last_dynamic_temp = 0; 9679 9680 return; /* code for merging states */ 9681 9682 flush_state: 9683 entry; 9684 9685 call flush_eaq (); 9686 9687 if current_ms.value_in_xr 9688 then do reg = first_index to last_index; 9689 call flush_xr (reg); 9690 end; 9691 9692 if current_ms.address_in_base 9693 then do reg = first_base to last_base; 9694 call flush_base (reg); 9695 end; 9696 9697 unspec (current_ms) = "0"b; 9698 9699 current_ms.base_regs (which_base (4)).type = 6; /* linkage_ptr */ 9700 9701 index_data.local, ptr_data.local = 0; 9702 9703 return; /* code to flush state */ 9704 9705 empty_the_eaq: 9706 procedure (r); 9707 9708 /* Marks the specified eaq register as empty. */ 9709 9710 dcl (r, n) fixed binary (18); 9711 9712 existing_state.eaq (r).name = 0; 9713 9714 n = existing_state.eaq (r).number; 9715 do while (n > 0); 9716 9717 if updating_ms 9718 then addr (rands (existing_state.eaq (r).variable (n))) -> node.value_in.eaq = "0"b; 9719 else call drop_ms_ref_count (addr (rands (existing_state.eaq (r).variable (n))), ("0"b)); 9720 9721 n = n - 1; 9722 9723 end; 9724 9725 existing_state.eaq (r).number = 0; 9726 existing_state.rounded = "0"b; 9727 9728 end empty_the_eaq; 9729 9730 empty_xr: 9731 procedure (); 9732 9733 /* Marks the specified index register as empty */ 9734 9735 if updating_ms 9736 then call flush_xr (reg); 9737 else if existing_state.index_regs (reg).type = 1 9738 then call drop_ms_ref_count (addr (rands (existing_state.index_regs (reg).variable)), ("0"b)); 9739 9740 existing_state.index_regs (reg).type = 0; 9741 existing_state.index_regs (reg).variable = 0; 9742 9743 end empty_xr; 9744 9745 empty_base: 9746 procedure (); 9747 9748 /* Marks the specified base register as empty */ 9749 9750 if updating_ms 9751 then call flush_base (reg); 9752 else if existing_state.base_regs (reg).type = 1 9753 then call drop_ms_ref_count (addr (rands (existing_state.base_regs (reg).variable)), ("0"b)); 9754 9755 existing_state.base_regs (reg).type = 0; 9756 existing_state.base_regs (reg).variable = 0; 9757 existing_state.base_regs (reg).offset = 0; 9758 9759 end empty_base; 9760 9761 end merge_state; 9762 9763 discard_state: 9764 procedure (); 9765 9766 /* Discard the machine state. Empty all the registers. */ 9767 9768 dcl i fixed binary (3); 9769 9770 if state_discarded 9771 then return; 9772 9773 if current_ms.address_in_base 9774 then do i = first_base to last_base; 9775 call flush_base (i); 9776 end; 9777 9778 call reset_eaq (EAQ); 9779 call reset_eaq (IND); 9780 9781 if current_ms.value_in_xr 9782 then do i = first_index to last_index; 9783 if current_ms.index_regs (i).type = 1 9784 then if current_ms.index_regs (i).variable ^= 0 9785 then addr (rands (current_ms.index_regs (i).variable)) -> node.value_in.x = "0"b; 9786 end; 9787 9788 unspec (current_ms) = "0"b; 9789 9790 index_data.local, ptr_data.local = 0; 9791 9792 state_discarded = "1"b; 9793 9794 end discard_state; 9795 9796 /**** GLOBAL REGISTER MANAGEMENT (See also find_global_base and find_global_index) ****/ 9797 9798 leave_loop: 9799 procedure (lp_msp); 9800 9801 /* Turns off global bits in current_ms and globally_assigned bits for 9802* operands globally assigned in this loop */ 9803 9804 dcl (msp, lp_msp) pointer; /* -> loop node's machine_state template */ 9805 9806 dcl 1 loop_state based (msp) aligned like machine_state; 9807 9808 dcl i fixed binary; 9809 9810 msp = lp_msp; 9811 9812 if msp ^= null 9813 then do; 9814 do i = first_base to last_base; 9815 current_ms.base_regs (i).global = "0"b; 9816 end; 9817 9818 do i = first_index to last_index; 9819 current_ms.index_regs (i).global = "0"b; 9820 9821 if loop_state.index_regs (i).type = 1 9822 then addr (rands (loop_state.index_regs (i).variable)) -> node.globally_assigned = "0"b; 9823 end; 9824 end; 9825 9826 end leave_loop; 9827 9828 enter_loop: 9829 procedure (lp, lp_msp); 9830 9831 /* Sets lp_msp for a new loop. Turns on the proper global bits in 9832* current_ms and turns on the globally_assigned bits for globally 9833* assigned operands */ 9834 9835 dcl lp pointer, /* -> loop node */ 9836 lp_msp pointer; /* loop_node's machine_state pointer (output) */ 9837 9838 dcl msp pointer; 9839 dcl 1 loop_state based (msp) aligned like machine_state; 9840 9841 dcl i fixed binary; 9842 9843 if lp ^= null 9844 then do; 9845 lp_msp, msp = lp -> loop.msp; 9846 9847 if msp ^= null 9848 then do; 9849 do i = first_base to last_base; 9850 current_ms.base_regs (i).global = loop_state.base_regs (i).global; 9851 end; 9852 9853 do i = first_index to last_index; 9854 current_ms.index_regs (i).global = loop_state.index_regs (i).global; 9855 9856 if loop_state.index_regs (i).type = 1 9857 then addr (rands (loop_state.index_regs (i).variable)) -> node.globally_assigned = "1"b; 9858 end; 9859 end; 9860 end; 9861 9862 end enter_loop; 9863 9864 refresh_global_bits: 9865 procedure (p_lp); 9866 9867 /* Refreshes the global bits in current_ms by copying them from the 9868* loop template, if it exists, or by zeroing them. */ 9869 9870 dcl (lp, p_lp) pointer; /* -> loop node */ 9871 9872 dcl i fixed binary; 9873 dcl useless pointer; 9874 9875 lp = p_lp; 9876 9877 if lp ^= null 9878 then if lp -> loop.msp ^= null 9879 then call enter_loop (lp, useless); 9880 else do; 9881 do i = first_base to last_base; 9882 current_ms.base_regs (i).global = "0"b; 9883 end; 9884 9885 do i = first_index to last_index; 9886 current_ms.index_regs (i).global = "0"b; 9887 end; 9888 end; 9889 9890 end refresh_global_bits; 9891 9892 adjust_state_for_globals: 9893 procedure (); 9894 9895 /* This is called when processing a label that has a backwards reference. 9896* It adds the globally assigned items to the current machine_state by 9897* looking in the loop node's template. */ 9898 9899 dcl i fixed binary; 9900 9901 if lp_msp ^= null 9902 then do; 9903 do i = first_base to last_base; 9904 if loop_state.base_regs (i).type ^= 0 9905 then current_ms.base_regs (i) = loop_state.base_regs (i); 9906 end; 9907 9908 do i = first_index to last_index; 9909 if loop_state.index_regs (i).type ^= 0 9910 then do; 9911 9912 /* type should be 1 (a variable or temp) */ 9913 9914 current_ms.index_regs (i) = loop_state.index_regs (i); 9915 addr (rands (current_ms.index_regs (i).variable)) -> node.value_in.x = "1"b; 9916 end; 9917 end; 9918 9919 current_ms.value_in_xr = loop_state.value_in_xr; 9920 current_ms.address_in_base = loop_state.address_in_base; 9921 end; 9922 9923 end adjust_state_for_globals; 9924 9925 cleanup_loop_state_nodes: 9926 procedure (); 9927 9928 dcl i fixed binary; 9929 dcl lp pointer; 9930 9931 do i = 1 to n_loops - 1; 9932 lp = loop_vector (i); 9933 if lp -> loop.msp ^= null 9934 then do; 9935 lp -> loop.msp -> machine_state.next = next_free_opt_ms; 9936 next_free_opt_ms = lp -> loop.msp; 9937 lp -> loop.msp = null; 9938 end; 9939 end; 9940 9941 end cleanup_loop_state_nodes; 9942 9943 refresh_regs: 9944 procedure (protect_ind); 9945 9946 /* This is called at the end of a flow_unit to ensure that all globally 9947* assigned values are in their proper registers. All registers are 9948* unlocked at the end of the routine. */ 9949 9950 dcl (protect_ind, protect_indicators) fixed binary (18); /* if ^= 0, protect indicators 9951* when loading xregs. */ 9952 9953 dcl saved_state fixed binary (18); 9954 9955 dcl (i, pass) fixed binary; 9956 dcl bit6 bit (6) aligned; 9957 dcl bit3 bit (3) aligned; 9958 9959 if ^fu -> flow_unit.refreshed & lp_msp ^= null 9960 then do; 9961 saved_state = 0; 9962 protect_indicators = protect_ind; 9963 9964 /* Refresh the index registers. */ 9965 9966 do i = first_index to last_index; 9967 if current_ms.index_regs (i).global & current_ms.index_regs (i).type <= 0 9968 then do; 9969 if protect_indicators ^= 0 & saved_state = 0 9970 then call save_ind_state (saved_state); 9971 bit6 = xr_man_load_any_xr (addr (rands (loop_state.index_regs (i).variable))); 9972 end; 9973 end; 9974 9975 /* Refresh the base registers. First refresh all the registers 9976* with offset = 0, then refresh the others. This avoids 9977* generating code to add an offset and then subtract it again 9978* if two pointers into the same region (stack, linkage, common 9979* block) with different offsets are to be loaded. */ 9980 9981 do pass = 1 to 2; 9982 do i = first_base to last_base; 9983 if current_ms.base_regs (i).global 9984 & (current_ms.base_regs (i).type <= 0 | current_ms.base_regs (i).type = 7) 9985 /* kludge for load_pr_value */ 9986 then if (pass = 1 & loop_state.base_regs (i).offset = 0) 9987 | (pass = 2 & loop_state.base_regs (i).offset ^= 0) 9988 then bit3 = 9989 base_man_dispatch (loop_state.base_regs (i).type, 9990 loop_state.base_regs (i).variable, loop_state.base_regs (i).offset); 9991 end; 9992 end; 9993 9994 /* Restore the indicators if xr_man altered them and they were protected. */ 9995 9996 if saved_state ^= 0 9997 then call restore_ind_state (saved_state); 9998 9999 /* Mark the flow_unit as refreshed so that we don't process redundantly. */ 10000 10001 fu -> flow_unit.refreshed = "1"b; 10002 end; 10003 10004 /* Free all locked registers. */ 10005 10006 call free_regs (); 10007 10008 end refresh_regs; 10009 10010 assign_register: 10011 procedure (p_adam, p_reg_type, p_regno, p_code, p_var, p_off); 10012 10013 /* Assigns an item to a register across adam and all loops contained in adam */ 10014 10015 dcl (adam, p_adam) pointer, /* -> loop nest over which reg is assigned */ 10016 (reg_type, p_reg_type) fixed binary, /* INDEX, BASE */ 10017 (regno, p_regno) fixed binary (3), /* register number */ 10018 (code, p_code) fixed binary (18), 10019 (var, p_var) fixed binary (18), 10020 (off, p_off) fixed binary (18); 10021 10022 dcl p pointer; 10023 10024 /* copy in the parameters */ 10025 10026 adam = p_adam; 10027 reg_type = p_reg_type; 10028 regno = p_regno; 10029 code = p_code; 10030 var = p_var; 10031 off = p_off; 10032 10033 /* assign the item to the register in adam */ 10034 10035 call assign (adam); 10036 10037 if adam -> loop.son = null 10038 then return; 10039 10040 /* By using a simulated recursive walk, assign the item to the register 10041* in all loops contained in adam. */ 10042 10043 p = adam -> loop.son; 10044 10045 do while ("1"b); 10046 call assign (p); 10047 10048 if p -> loop.son ^= null 10049 then p = p -> loop.son; 10050 10051 else do; 10052 do while (p -> loop.brother = null); 10053 p = p -> loop.father; 10054 if p = adam 10055 then return; 10056 end; 10057 10058 p = p -> loop.brother; 10059 end; 10060 10061 end; 10062 10063 return; 10064 10065 assign: 10066 procedure (lp); 10067 10068 dcl lp pointer; /* -> loop node */ 10069 10070 dcl msp pointer; 10071 10072 if lp -> loop.msp ^= null 10073 then msp = lp -> loop.msp; 10074 else lp -> loop.msp, msp = create_machine_state (); 10075 10076 if reg_type = INDEX 10077 then do; 10078 msp -> machine_state.index_regs (regno).global = "1"b; 10079 msp -> machine_state.index_regs (regno).type = code; 10080 msp -> machine_state.index_regs (regno).variable = var; 10081 msp -> machine_state.value_in_xr = "1"b; 10082 end; 10083 10084 else do; 10085 msp -> machine_state.base_regs (regno).global = "1"b; 10086 msp -> machine_state.base_regs (regno).type = code; 10087 msp -> machine_state.base_regs (regno).variable = var; 10088 msp -> machine_state.base_regs (regno).offset = off; 10089 if code = 1 10090 then msp -> machine_state.address_in_base = "1"b; 10091 end; 10092 10093 end assign; 10094 10095 end assign_register; 10096 10097 create_machine_state: 10098 procedure () returns (pointer); 10099 10100 /* Allocates a machine_state node */ 10101 10102 dcl msp pointer; 10103 10104 if next_free_opt_ms = null 10105 then msp = get_opt_space (size (machine_state)); 10106 else do; 10107 msp = next_free_opt_ms; 10108 next_free_opt_ms = msp -> machine_state.next; 10109 unspec (msp -> machine_state) = "0"b; 10110 end; 10111 10112 msp -> machine_state.node_type = machine_state_node; 10113 msp -> machine_state.next = null; 10114 10115 return (msp); 10116 10117 end create_machine_state; 10118 10119 is_induction_var: 10120 procedure (p) returns (bit (1) aligned); 10121 10122 /* Returns "1"b if p -> symbol for an induction variable in cur_lp */ 10123 10124 dcl p pointer; 10125 10126 if p -> node.node_type = symbol_node 10127 then if p -> symbol.coordinate > 0 10128 then return (substr (cur_lp -> loop.induction_var -> bits, p -> symbol.coordinate, 1)); 10129 10130 return ("0"b); 10131 10132 end is_induction_var; 10133 10134 find_range: 10135 procedure (pt, lp) returns (pointer); 10136 10137 /* Finds range data for a variable. */ 10138 10139 dcl ( 10140 p unaligned, 10141 pt 10142 ) pointer, /* -> symbol node */ 10143 lp pointer; /* -> loop node */ 10144 10145 dcl r pointer; 10146 10147 p = pt; 10148 10149 do r = lp -> loop.range_list repeat r -> range.next while (r ^= null); 10150 if p = r -> range.variable 10151 then return (r); 10152 end; 10153 10154 return (null); 10155 10156 end find_range; 10157 10158 definitely_initialized: 10159 procedure (coord, start_fu) returns (bit (1) aligned); 10160 10161 dcl coord fixed binary (18), /* Coordinate of symbol that we're checking out */ 10162 start_fu pointer; /* Flow_unit in which we're trying to check out the symbol */ 10163 10164 dcl i fixed binary; 10165 dcl fu pointer; 10166 10167 /* We attempt to determine if a symbol has been definitely 10168* initialized by searching back along the dominator chain. 10169* This is not really the best method for accuracy or speed. 10170* If this is important, it should be done by a more formal 10171* data_flow_analysis method in fort_optimizer. This algorithm 10172* does err on the side of safety. */ 10173 10174 i = coord; 10175 10176 do fu = start_fu repeat fu -> flow_unit.dominator while (fu ^= null); 10177 if substr (fu -> flow_unit.always_completely_set -> bits, i, 1) 10178 then return ("1"b); 10179 end; 10180 10181 return ("0"b); 10182 10183 end definitely_initialized; 10184 10185 /**** REFERENCE COUNTS ****/ 10186 10187 get_ref_count: 10188 procedure (p) returns (fixed binary (18)); 10189 10190 /* Returns temporary.ref_count or temporary.ref_count_copy depending 10191* on whether we are analyzing or generating code. */ 10192 10193 dcl p pointer; /* -> temporary node or array_ref node */ 10194 10195 if analyzing 10196 then return (p -> temporary.ref_count_copy); 10197 else return (p -> temporary.ref_count); 10198 10199 end get_ref_count; 10200 10201 bump_count: 10202 procedure (opnd, incre); 10203 10204 /* Increments ref count of opnd by incre */ 10205 10206 dcl opnd fixed binary (18); 10207 dcl incre fixed binary (18); /* amount to bump ref count */ 10208 10209 dcl p pointer; 10210 10211 p = addr (rands (opnd)); 10212 10213 if p -> node.node_type = array_ref_node | p -> node.node_type = temporary_node 10214 then if analyzing 10215 then p -> temporary.ref_count_copy = p -> temporary.ref_count_copy + incre; 10216 else p -> temporary.ref_count = p -> temporary.ref_count + incre; 10217 10218 end bump_count; 10219 10220 drop_count: 10221 procedure (opnd, incre); 10222 10223 /* Decrement ref count of opnd by incre */ 10224 10225 dcl opnd fixed binary (18); 10226 dcl incre fixed binary (18); /* amount to drop ref count */ 10227 dcl tp pointer; 10228 dcl n fixed binary; 10229 10230 if opnd > 0 10231 then do; 10232 tp = addr (rands (opnd)); 10233 10234 if tp -> node.node_type = array_ref_node 10235 then do; 10236 if analyzing 10237 then n, tp -> array_ref.ref_count_copy = tp -> array_ref.ref_count_copy - incre; 10238 else n, tp -> array_ref.ref_count = tp -> array_ref.ref_count - incre; 10239 if n <= 0 10240 then call free_array_ref (tp); 10241 end; 10242 10243 else if tp -> node.node_type = temporary_node 10244 then do; 10245 if analyzing 10246 then n, tp -> temporary.ref_count_copy = tp -> temporary.ref_count_copy - incre; 10247 else n, tp -> temporary.ref_count = tp -> temporary.ref_count - incre; 10248 if n <= 0 10249 then call free_temp (tp); 10250 end; 10251 end; 10252 10253 end drop_count; 10254 10255 bump_all_ms_ref_counts: 10256 procedure (); 10257 10258 /* Bumps ms_ref_count for everything currently in the machine state */ 10259 10260 dcl (i, r) fixed binary (18); 10261 10262 do r = 1 to hbound (current_ms.eaq, 1); /* A, Q, EAQ, IND */ 10263 do i = 1 to current_ms.eaq (r).number; 10264 call bump_ms_ref_count (addr (rands (current_ms.eaq (r).variable (i)))); 10265 end; 10266 end; 10267 10268 if current_ms.value_in_xr 10269 then do i = first_index to last_index; 10270 if current_ms.index_regs (i).type = 1 10271 then call bump_ms_ref_count (addr (rands (current_ms.index_regs (i).variable))); 10272 end; 10273 10274 if current_ms.address_in_base 10275 then do i = first_base to last_base; 10276 if current_ms.base_regs (i).type = 1 10277 then call bump_ms_ref_count (addr (rands (current_ms.base_regs (i).variable))); 10278 end; 10279 10280 return; 10281 10282 bump_ms_ref_count: 10283 procedure (node_pt); 10284 10285 /* Bumps ms ref count for the given operand */ 10286 10287 dcl node_pt pointer; 10288 10289 if node_pt -> node.node_type = temporary_node 10290 then node_pt -> temporary.ms_ref_count = node_pt -> temporary.ms_ref_count + 1; 10291 10292 end bump_ms_ref_count; 10293 10294 end bump_all_ms_ref_counts; 10295 10296 drop_all_ms_ref_counts: 10297 procedure (affected_ms); 10298 10299 /* Drops ms_ref_count for everything in specified machine state */ 10300 10301 dcl 1 affected_ms aligned like machine_state; 10302 dcl count_is_zero bit (1) aligned; 10303 dcl (i, j, r) fixed binary (18); 10304 10305 do r = 1 to hbound (current_ms.eaq, 1); /* A, Q, EAQ, IND */ 10306 do i = affected_ms.eaq (r).number to 1 by -1; 10307 call drop_ms_ref_count (addr (rands (affected_ms.eaq (r).variable (i))), count_is_zero); 10308 10309 if count_is_zero 10310 then do; 10311 affected_ms.eaq (r).number = affected_ms.eaq (r).number - 1; 10312 do j = i to affected_ms.eaq (r).number; 10313 affected_ms.eaq (r).variable (j) = affected_ms.eaq (r).variable (j + 1); 10314 end; 10315 end; 10316 end; 10317 10318 if affected_ms.eaq (r).number = 0 10319 then affected_ms.eaq (r).name = 0; 10320 10321 end; 10322 10323 if affected_ms.value_in_xr 10324 then do i = first_index to last_index; 10325 if affected_ms.index_regs (i).type = 1 10326 then do; 10327 call drop_ms_ref_count (addr (rands (affected_ms.index_regs (i).variable)), count_is_zero); 10328 10329 if count_is_zero 10330 then affected_ms.index_regs (i).type, affected_ms.index_regs (i).variable = 0; 10331 end; 10332 end; 10333 10334 if affected_ms.address_in_base 10335 then do i = first_base to last_base; 10336 if affected_ms.base_regs (i).type = 1 10337 then do; 10338 call drop_ms_ref_count (addr (rands (affected_ms.base_regs (i).variable)), count_is_zero); 10339 10340 if count_is_zero 10341 then affected_ms.base_regs (i).type, affected_ms.base_regs (i).variable = 0; 10342 end; 10343 end; 10344 10345 end drop_all_ms_ref_counts; 10346 10347 drop_ms_ref_count: 10348 procedure (node_pt, ref_count_is_zero); 10349 10350 /* Drops the ms ref_count of the given operand */ 10351 10352 dcl node_pt pointer; 10353 dcl ref_count_is_zero bit (1) aligned; /* true ref_count, not ms_ref_count, is zero */ 10354 10355 if node_pt -> node.node_type = temporary_node 10356 then do; 10357 node_pt -> temporary.ms_ref_count = node_pt -> temporary.ms_ref_count - 1; 10358 10359 if get_ref_count (node_pt) <= 0 10360 then do; 10361 ref_count_is_zero = "1"b; 10362 if node_pt -> temporary.ms_ref_count <= 0 10363 then call free_temp ((node_pt)); 10364 end; 10365 else ref_count_is_zero = "0"b; 10366 end; 10367 else ref_count_is_zero = "0"b; 10368 10369 end drop_ms_ref_count; 10370 10371 /**** REL_CONSTANTS ****/ 10372 10373 alloc_relcon: 10374 procedure (opnd, value); 10375 10376 /* Allocates a rel_constant */ 10377 10378 dcl opnd fixed binary (18), /* Operand offset in region */ 10379 value fixed binary (18); /* Value to be assigned to operand */ 10380 10381 dcl p pointer; 10382 10383 p = addr (rands (opnd)); 10384 10385 p -> label.location = value; 10386 p -> label.allocated = "1"b; 10387 10388 end alloc_relcon; 10389 10390 alloc_label: 10391 procedure (a_opnd, value); 10392 10393 /* Does everything required to "define" an executable rel const. */ 10394 10395 dcl a_opnd fixed binary (18); 10396 dcl value fixed binary (18); 10397 dcl opnd fixed binary (18); 10398 dcl (lbl, st) pointer; 10399 10400 opnd = a_opnd; 10401 lbl = addr (rands (opnd)); 10402 10403 if lbl -> label.referenced_executable 10404 then if lbl -> label.statement > 0 10405 then do; 10406 st = addr (quad (lbl -> label.statement)); 10407 10408 /* set up correct machine state; flush state if label is backward ref */ 10409 10410 if st -> opt_statement.referenced_backwards | st -> opt_statement.referenced_by_assign 10411 then if st -> opt_statement.machine_state = 0 10412 then do; 10413 call flush_state; /* flush machine state since we have no info on regs */ 10414 call adjust_state_for_globals;/* any globally assigned items can be added to ms */ 10415 10416 /* force doubleword alignment for entry of innermost loop */ 10417 10418 if mod (value, 2) ^= 0 & cur_lp -> loop.son = null & cur_lp -> loop.entry_unit = fu 10419 then call emit_zero (nop); 10420 end; 10421 10422 else do; /* statement cannot have a machine state!!! */ 10423 call print_message (444); /* fatal */ 10424 return; 10425 end; 10426 10427 else if st -> opt_statement.machine_state > 0 10428 then do; 10429 call merge_state (current_ms, addr (rands (st -> opt_statement.machine_state)) -> machine_state, 10430 "1"b); 10431 st -> opt_statement.machine_state = 0; 10432 end; 10433 10434 state_discarded = "0"b; 10435 end; 10436 10437 call alloc_relcon (opnd, (value)); 10438 10439 if lbl -> label.restore_prs 10440 then call emit_zero (getlp); /* Restore frozen ptr reg (pr4) */ 10441 10442 end alloc_label; 10443 10444 /**** BUILD PROFILE ENTRY ****/ 10445 10446 build_profile_entry: 10447 procedure (); 10448 10449 if ^generate_long_profile 10450 then call use_ind; /* aos sets indicators */ 10451 10452 if analyzing 10453 then return; /* modified to produce both long and short profile. */ 10454 10455 if generate_long_profile 10456 then do; /* long_profile */ 10457 call emit_operator_call (long_profile); 10458 10459 /* emit internal static relative offset to long_profile_header */ 10460 10461 text_halfs (text_pos).left = profile_start; 10462 reloc (text_pos).left_rel = rc_is18; 10463 10464 /* emit relative offset from long_profile_header to entry */ 10465 10466 text_halfs (text_pos).right = profile_pos; 10467 reloc (text_pos).right_rel = rc_a; 10468 text_pos = text_pos + 1; 10469 profile_pos = profile_pos + size (long_profile_entry); 10470 end; 10471 else do; /* short profile */ 10472 call emit_c_a (aos, c_a (profile_pos + 1, 5)); 10473 reloc (text_pos - 1).left_rel = rc_is15; 10474 10475 profile_pos = profile_pos + size (profile_entry); 10476 end; 10477 10478 end build_profile_entry; 10479 10480 setup_message_structure: 10481 procedure (); 10482 10483 /* Sets up message_structure for print & error macros */ 10484 10485 dcl i fixed binary (18); 10486 10487 message_structure.message_number = left; 10488 message_structure.number_of_operands = macro_dt_inst (imac).data_type; 10489 10490 do i = 1 to message_structure.number_of_operands; 10491 imac = imac + 1; 10492 10493 left = macro_instruction (imac).left; 10494 if left = 0 10495 then do; 10496 10497 /* have an operand as argument */ 10498 10499 message_structure.is_string (i) = "0"b; 10500 message_structure.operand_index (i) = stack (get_operand ((macro_instruction (imac).operand))); 10501 end; 10502 10503 else do; 10504 10505 /* have a string as argument */ 10506 10507 message_structure.is_string (i) = "1"b; 10508 message_structure.string_length (i) = macro_dt_inst (imac).data_type; 10509 message_structure.string_ptr (i) = addrel (mac_base, macro_instruction (imac).left); 10510 end; 10511 end; 10512 10513 end setup_message_structure; 10514 10515 create_integer_constant: 10516 procedure (value) returns (fixed binary (18)); 10517 10518 dcl value fixed binary (35) aligned; 10519 dcl bvalue bit (72) aligned; 10520 10521 bvalue = unspec (value); 10522 return (create_constant (int_mode, bvalue)); 10523 10524 end create_integer_constant; 10525 10526 /**** SUBSCRIPTING CODE ****/ 10527 10528 /* format: style4,delnl,insnl,^ifthendo,indnoniterend,inditerdo,indend,^indproc,indcom,declareind5 */ 10529 optimized_subscript: 10530 procedure (quad_ptr); 10531 10532 /* Prepares an array_ref node by using the operands of the 10533* opt_subscript operator that produced it. */ 10534 10535 dcl quad_ptr pointer; /* -> opt_subscript producing the array_ref */ 10536 10537 dcl (symbol_ptr, t, len) pointer; 10538 dcl (i, csize) fixed binary (18); 10539 10540 dcl 1 constant_address aligned, 10541 2 location fixed binary (17) unaligned, 10542 2 fill bit (11) unaligned, 10543 2 ext_base bit (1) unaligned, 10544 2 tag bit (6) unaligned; 10545 10546 t = addr (rands (quad_ptr -> operator.output)); 10547 10548 if get_ref_count (t) = 0 10549 then do; 10550 if ^analyzing 10551 then call print_message (454, (quad_ptr -> operator.output)); 10552 return; 10553 end; 10554 10555 t -> array_ref.dont_update = "0"b; 10556 10557 if t -> array_ref.has_address /* see if already done */ 10558 then return; 10559 10560 symbol_ptr = addr (rands (quad_ptr -> operator.operand (1))); 10561 10562 if quad_ptr -> operator.operand (3) = 0 /* =0 if no variable offset */ 10563 then t -> array_ref.variable_offset = "0"b; 10564 else do; 10565 t -> array_ref.variable_offset = "1"b; 10566 t -> array_ref.v_offset = quad_ptr -> operator.operand (3); 10567 end; 10568 10569 t -> array_ref.variable_length = "0"b; 10570 10571 if symbol_ptr -> symbol.VLA 10572 then do; 10573 t -> array_ref.needs_pointer = "1"b; 10574 unspec (t -> array_ref.address) = ""b; 10575 t -> array_ref.ext_base = "1"b; 10576 end; 10577 else do; 10578 if quad_ptr -> operator.number = 4 10579 then do; 10580 10581 /* Fourth operand is length of substring reference */ 10582 10583 len = addr (rands (quad_ptr -> operator.operand (4))); 10584 if len -> node.operand_type = constant_type 10585 then do; 10586 csize = addr (len -> constant.value) -> int_image; 10587 if csize < 1 10588 then do; 10589 call print_message (460, quad_ptr -> operator.operand (1)); 10590 imac = fixed (rel (addr (fort_opt_macros_$error_macro)), 18); 10591 go to loop; 10592 end; 10593 t -> array_ref.length = csize; 10594 end; 10595 else do; 10596 t -> array_ref.variable_length = "1"b; 10597 t -> array_ref.length = quad_ptr -> operator.operand (4); 10598 end; 10599 end; 10600 10601 else if t -> array_ref.data_type = char_mode 10602 then do; 10603 csize = get_char_size (symbol_ptr); 10604 if csize < 0 10605 then t -> array_ref.length = csize + bias; 10606 else do; 10607 t -> array_ref.variable_length = "1"b; 10608 t -> array_ref.length = csize; 10609 end; 10610 end; 10611 10612 t -> array_ref.needs_pointer = symbol_ptr -> symbol.needs_pointer; 10613 10614 if symbol_ptr -> symbol.named_constant 10615 then do; 10616 unspec (t -> array_ref.address) = (36)"0"b; 10617 t -> array_ref.reloc = rc_t; 10618 i = addr (rands (symbol_ptr -> symbol.initial)) -> char_constant.address.location; 10619 end; 10620 else do; 10621 unspec (t -> array_ref.address) = unspec (symbol_ptr -> symbol.address); 10622 t -> array_ref.reloc = symbol_ptr -> symbol.reloc; 10623 i = symbol_ptr -> symbol.address.offset; 10624 end; 10625 10626 if ^t -> array_ref.variable_offset 10627 then t -> array_ref.is_addressable = ^t -> array_ref.needs_pointer; 10628 10629 t -> array_ref.units = symbol_ptr -> symbol.units; 10630 10631 if symbol_ptr -> symbol.large_address 10632 then i = i + symbol_ptr -> symbol.location; 10633 10634 if symbol_ptr -> symbol.units = char_units 10635 then i = i * chars_per_word + symbol_ptr -> symbol.address.char_num; 10636 10637 i = i + addr (addr (rands (quad_ptr -> operator.operand (2))) -> constant.value) -> int_image; 10638 10639 if symbol_ptr -> symbol.units = char_units 10640 then do; 10641 t -> array_ref.address.char_num = mod (i, chars_per_word); 10642 if (i < 0) & (t -> array_ref.address.char_num ^= 0) 10643 then i = divide (i, chars_per_word, 18, 0) - 1; 10644 else i = divide (i, chars_per_word, 18, 0); 10645 end; 10646 10647 if symbol_ptr -> symbol.named_constant 10648 then do; 10649 constant_address.location = i; 10650 substr (unspec (t -> array_ref.address), 1, 18) = unspec (constant_address.location); 10651 end; 10652 else do; 10653 10654 /* If the symbol node had large_addressing then the base in the array_ref 10655* node will be incorrect if the array ref is a ^large_address. Therefore 10656* or large_address flags to cause base re-evaluation if required. */ 10657 10658 10659 call set_address_offset (t, i, (symbol_ptr -> symbol.element_size), (symbol_ptr -> symbol.units)); 10660 t -> array_ref.large_address = t -> array_ref.large_address | symbol_ptr -> symbol.large_address; 10661 end; 10662 end; 10663 10664 t -> array_ref.has_address = "1"b; 10665 10666 /* The opt_subscript operator counts as a use of the offset 10667* and length temporaries, which should decrement their ref 10668* counts. However, we also connect these temporaries to the 10669* output array_ref node, which should increment their ref 10670* counts. Thus, the two operations cancel, and we do nothing 10671* to the reference counts. */ 10672 10673 end optimized_subscript; 10674 10675 get_param_array_size: 10676 procedure (sym); 10677 10678 /* Figures out the size of parameter arrays of 10679* expression extents */ 10680 10681 dcl (d, s) pointer; 10682 dcl (vsum, i) fixed binary (18); 10683 dcl code_emitted bit (1) aligned; 10684 10685 dcl sym pointer; 10686 10687 dcl (virtual_origin, array_size, c_virtual_origin, c_multiplier, ndims, c_mult_offset, desc) fixed binary (18); 10688 dcl v_multiplier bit (1) aligned; 10689 dcl vo_already_set bit (1) aligned; 10690 10691 s = sym; 10692 10693 if ^s -> symbol.variable_extents & ^s -> symbol.star_extents 10694 then return; 10695 10696 desc = s -> symbol.hash_chain; 10697 10698 /* If there is a descriptor template node, but it has not been 10699* assigned storage, then it is only needed to build the entry 10700* point definitions and we can ignore it. */ 10701 10702 if desc ^= 0 10703 then if ^addr (rands (desc)) -> symbol.allocated 10704 then desc = 0; 10705 10706 d = addr (rands (s -> symbol.dimension)); 10707 10708 ndims = d -> dimension.number_of_dims; 10709 10710 /* Get array_size symbol */ 10711 10712 array_size = d -> dimension.array_size; 10713 10714 /* Copy descriptor template to automatic storage, but only 10715* if get_param_char_size has not done so already. */ 10716 10717 if desc ^= 0 & s -> symbol.v_length = 0 10718 then call copy_array_desc_template (s); 10719 10720 /* The rest of the code concerns itself with computing 10721* the array size and virtual origin, and with initializing 10722* the bound information in the descriptor. */ 10723 10724 /* For some 1 dimensional arrays, we can emit a more efficient 10725* code sequence than is possible in the general case. */ 10726 10727 if ndims = 1 & desc = 0 & s -> symbol.v_length = 0 & ^d -> dimension.v_bound (1).lower 10728 then do; 10729 d -> dimension.virtual_origin = s -> symbol.element_size * d -> dimension.lower_bound (1); 10730 d -> dimension.has_virtual_origin = "1"b; 10731 d -> dimension.variable_virtual_origin = "0"b; 10732 10733 code_emitted = "1"b; 10734 call compute_dimension_size (1); 10735 10736 if ^d -> dimension.assumed_size 10737 then do; 10738 call load ((d -> dimension.size (1)), in_q); 10739 call mult (s -> symbol.element_size - bias); 10740 call store (array_size, in_q, 0); 10741 end; 10742 return; 10743 end; 10744 10745 /* The more general sequence must be used. */ 10746 10747 code_emitted = "0"b; 10748 virtual_origin = 0; 10749 c_virtual_origin = 0; 10750 10751 if s -> symbol.v_length = 0 10752 then do; 10753 c_multiplier = s -> symbol.element_size; 10754 v_multiplier = "0"b; 10755 end; 10756 else do; 10757 c_multiplier = 1; 10758 v_multiplier = "1"b; 10759 end; 10760 10761 if s -> symbol.units = char_units & desc ^= 0 & v_multiplier & shared_globals.user_options.table 10762 then c_mult_offset = ndims * 3; /* possible variable dims */ 10763 else c_mult_offset = 0; /* constant dims */ 10764 10765 do i = 1 to ndims; 10766 10767 /* This section of code accumulates the virtual origin 10768* and array size as long as the dimension bounds remain 10769* constant. When a variable bound is encountered, code 10770* is emitted to initialize the virtual origin and array 10771* size to the accumulated partial result. */ 10772 /* if we start with a variable multiplier (i.e. symbol.v_length 10773* ^= 0 then ALL MULTIPLIERS MUST BE CALCULATED, not just the 10774* LAST one. */ 10775 10776 if ^code_emitted 10777 then do; 10778 if string (d -> dimension.v_bound (i)) = "00"b & i < ndims & ^v_multiplier 10779 then do; 10780 c_virtual_origin = c_virtual_origin + c_multiplier * d -> dimension.lower_bound (i); 10781 c_multiplier = c_multiplier * d -> dimension.size (i); 10782 end; 10783 else do; 10784 code_emitted = "1"b; 10785 if i = ndims & ^v_multiplier & ^d -> dimension.v_bound (i).lower 10786 then do; 10787 10788 /* The virtual origin is constant. */ 10789 10790 d -> dimension.virtual_origin = 10791 c_virtual_origin + c_multiplier * d -> dimension.lower_bound (i); 10792 d -> dimension.has_virtual_origin = "1"b; 10793 d -> dimension.variable_virtual_origin = "0"b; 10794 end; 10795 else do; 10796 10797 /* The virtual origin is variable. */ 10798 10799 virtual_origin = get_virtual_origin (s, vo_already_set); 10800 10801 if ^vo_already_set 10802 then do; 10803 if c_virtual_origin = 0 10804 then call emit_single (stz, virtual_origin); 10805 else do; 10806 if v_multiplier 10807 then do; 10808 call load ((s -> symbol.v_length), in_q); 10809 call mult (c_virtual_origin - bias); 10810 end; 10811 else call load (create_integer_constant ((c_virtual_origin)), in_q); 10812 call store (virtual_origin, in_q, 0); 10813 end; 10814 end; 10815 end; 10816 10817 /* Initialize the array size. */ 10818 10819 if v_multiplier 10820 then do; 10821 call load ((s -> symbol.v_length), in_q); 10822 call mult (c_multiplier - bias); 10823 end; 10824 else call load (create_integer_constant ((c_multiplier)), in_q); 10825 10826 /* The array size is left in the Q register. */ 10827 10828 call in_reg (array_size, in_q); 10829 end; 10830 end; 10831 10832 /* The following block of code is executed once a variable 10833* array bound has been encountered. */ 10834 10835 if code_emitted 10836 then do; 10837 10838 /* Store the multiplier for this dimension in the 10839* descriptor if appropriate. */ 10840 /* If we will generate a runtime symbol entry and we have 10841* star_extents in a character string then save the byte 10842* length in the runtime multiplier and the bit length will 10843* be concocted later and stored in the true descriptor. */ 10844 10845 if desc ^= 0 & v_multiplier 10846 then if c_mult_offset ^= 0 10847 then call emit_single_with_inc (store_inst (in_q), desc, c_mult_offset + i); 10848 else call emit_single_with_inc (store_inst (in_q), desc, 3 * i); 10849 10850 /* Store the array size if necessary. If the lower 10851* bound is known to be 1, we do not need to store the 10852* array size because (1) multiplying it by 1 to compute 10853* the virtual origin doesn't change it and (2) the Q 10854* is left intact by compute_dimension_size in this 10855* particular case. */ 10856 10857 if d -> dimension.v_bound (i).lower | d -> dimension.lower_bound (i) ^= 1 10858 then call store (array_size, in_q, 1); 10859 10860 /* Update the virtual origin. */ 10861 10862 if virtual_origin ^= 0 & ^vo_already_set 10863 then do; 10864 if d -> dimension.v_bound (i).lower 10865 then call mult ((d -> dimension.lower_bound (i))); 10866 else if d -> dimension.lower_bound (i) ^= 1 10867 then call mult (d -> dimension.lower_bound (i) - bias); 10868 10869 call emit_single (asq, virtual_origin); 10870 end; 10871 10872 /* Compute the size of this dimension, and store the 10873* bounds in the array's descriptor. */ 10874 10875 call compute_dimension_size (i); 10876 10877 /* Update the array size to include the size of this 10878* dimension. One of two code sequences is chosen 10879* depending on what is in the Q register. This need 10880* not be done if this is the last dimension of an 10881* assumed size array. */ 10882 10883 if i < ndims | ^d -> dimension.assumed_size 10884 then do; 10885 if get_eaq_name (array_size) = in_q 10886 then do; 10887 10888 /* Multiply by dimension size. */ 10889 10890 call load (array_size, in_q); 10891 if string (d -> dimension.v_bound (i)) = "00"b 10892 then call mult (d -> dimension.size (i) - bias); 10893 else call mult ((d -> dimension.size (i))); 10894 end; 10895 else do; 10896 10897 /* Multiply by array size. */ 10898 10899 if string (d -> dimension.v_bound (i)) = "00"b 10900 then call load (create_integer_constant ((d -> dimension.size (i))), in_q); 10901 else call load ((d -> dimension.size (i)), in_q); 10902 call mult (array_size); 10903 end; 10904 10905 /* The updated array size is left in the Q. */ 10906 10907 call in_reg (array_size, in_q); 10908 end; 10909 10910 /* If bounds are variable, so is multiplier. */ 10911 10912 v_multiplier = v_multiplier | (string (d -> dimension.v_bound (i)) ^= "00"b); 10913 end; 10914 10915 end; 10916 10917 /* Store the array size. */ 10918 10919 if ^d -> dimension.assumed_size 10920 then call store (array_size, in_q, 1); 10921 10922 /* If the array is in character units and there is a descriptor, 10923* the mulipliers must be converted from characters to bits. */ 10924 10925 if s -> symbol.units = char_units & desc ^= 0 10926 then do; 10927 if s -> symbol.v_length ^= 0 10928 then i = 1; 10929 else i = 2; 10930 do i = i to ndims; 10931 if c_mult_offset ^= 0 10932 then call emit_single_with_inc (load_inst (in_q), desc, c_mult_offset + i); 10933 else call emit_single_with_inc (load_inst (in_q), desc, 3 * i); 10934 call emit_single (mpy, bits_per_char - bias); 10935 call emit_single_with_inc (store_inst (in_q), desc, 3 * i); 10936 end; 10937 call reset_eaq (Q); 10938 end; 10939 10940 return; 10941 10942 compute_dimension_size: 10943 procedure (dim_no); 10944 10945 /* Emits code to compute the number of elements in a given 10946* dimension. Also stores variable array bounds in the array 10947* descriptor. */ 10948 10949 dcl dim_no fixed binary (18); 10950 dcl i fixed binary (3); 10951 10952 i = dim_no; 10953 10954 /* If this is the last dimension of an assumed size array, 10955* the dimension size must not be calculated. Simply copy 10956* the lower bound to the descriptor if necessary. */ 10957 10958 if (i = ndims) & d -> dimension.assumed_size 10959 then do; 10960 if (desc ^= 0) & d -> dimension.v_bound (i).lower 10961 then do; 10962 call emit_single (load_inst (in_a), (d -> dimension.lower_bound (i))); 10963 call emit_single_with_inc (store_inst (in_a), desc, 3 * i - 2); 10964 end; 10965 return; 10966 end; 10967 10968 /* The dimension size must be computed. */ 10969 10970 if string (d -> dimension.v_bound (i)) = "01"b 10971 then do; 10972 if d -> dimension.lower_bound (i) = 1 10973 then do; 10974 10975 /* Lower bound is the constant 1. The dimension size 10976* is already correct. If the upper bound needs to be 10977* copied to the descriptor, we use the A register, as 10978* the main loop in get_param_array_size depends on 10979* the Q register remaining intact. */ 10980 10981 if desc ^= 0 10982 then do; 10983 call emit_single (load_inst (in_a), (d -> dimension.upper_bound (i))); 10984 call emit_single_with_inc (store_inst (in_a), desc, 3 * i - 1); 10985 end; 10986 end; 10987 else do; 10988 10989 /* Lower bound is some constant other than 1. */ 10990 10991 call load ((d -> dimension.upper_bound (i)), in_q); 10992 if desc ^= 0 10993 then call emit_single_with_inc (store_inst (in_q), desc, 3 * i - 1); 10994 call sub (d -> dimension.lower_bound (i) - 1 - bias); 10995 call store ((d -> dimension.size (i)), in_q, 0); 10996 end; 10997 end; 10998 10999 else if string (d -> dimension.v_bound (i)) = "10"b 11000 then do; 11001 if desc ^= 0 11002 then do; 11003 call emit_single (load_inst (in_a), (d -> dimension.lower_bound (i))); 11004 call emit_single_with_inc (store_inst (in_a), desc, 3 * i - 2); 11005 end; 11006 call load (create_integer_constant (1 + d -> dimension.upper_bound (i)), in_q); 11007 call sub ((d -> dimension.lower_bound (i))); 11008 call store ((d -> dimension.size (i)), in_q, 0); 11009 end; 11010 11011 else if string (d -> dimension.v_bound (i)) = "11"b 11012 then do; 11013 if desc ^= 0 11014 then do; 11015 call emit_single (load_inst (in_a), (d -> dimension.lower_bound (i))); 11016 call emit_single_with_inc (store_inst (in_a), desc, 3 * i - 2); 11017 end; 11018 call load ((d -> dimension.upper_bound (i)), in_q); 11019 if desc ^= 0 11020 then call emit_single_with_inc (store_inst (in_q), desc, 3 * i - 1); 11021 call sub ((d -> dimension.lower_bound (i))); 11022 call add (1 - bias); 11023 call store ((d -> dimension.size (i)), in_q, 0); 11024 end; 11025 11026 end compute_dimension_size; 11027 11028 load_vsum: 11029 procedure (); 11030 11031 /* Emits code to load the variable sum into the Q */ 11032 11033 call load (vsum, in_q); 11034 code_emitted = "1"b; 11035 11036 end load_vsum; 11037 11038 mult: 11039 procedure (op); 11040 11041 /* Emits code to multiply the variable sum by op */ 11042 11043 dcl op fixed binary (18); 11044 11045 if ^code_emitted 11046 then call load_vsum; 11047 11048 if op + bias < 0 11049 then call copy (create_integer_constant (op + bias)); 11050 else call copy (op); 11051 call interpreter_proc (subscript_mpy, r2); 11052 r2: 11053 call reset_eaq (Q); /* Value has been modified */ 11054 11055 end mult; 11056 11057 add: 11058 procedure (op); 11059 11060 /* Emits code to add op to the variable sum in the Q */ 11061 11062 dcl (mac, op) fixed binary (18); 11063 11064 mac = adfx1; 11065 go to join; 11066 11067 11068 sub: 11069 entry (op); 11070 11071 /* Emits code to subtract op from the variable sum in the Q */ 11072 11073 mac = sbfx1; 11074 11075 join: 11076 if ^code_emitted 11077 then call load_vsum (); 11078 11079 if op + bias < 0 11080 then call emit_single (mac, create_integer_constant (op + bias)); 11081 else call emit_single (mac, op); 11082 11083 call reset_eaq (Q); 11084 11085 end add; 11086 11087 end get_param_array_size; 11088 11089 get_virtual_origin: 11090 procedure (symbol_ptr, found) returns (fixed binary (18)); 11091 11092 /* Returns the operand offset of an array's virtual origin 11093* symbol. found is turned on if the virtual origin is found in 11094* the list of those virtual origins that have already been 11095* computed in the current entry sequence. */ 11096 11097 dcl symbol_ptr pointer; 11098 dcl found bit (1) aligned; 11099 11100 dcl (s, d) pointer; 11101 dcl i fixed binary (17); 11102 11103 s = symbol_ptr; 11104 d = addr (rands (s -> symbol.dimension)); 11105 11106 if s -> symbol.star_extents 11107 then do; 11108 found = "0"b; 11109 return (d -> dimension.virtual_origin); 11110 end; 11111 11112 do i = 1 by 1 while (i <= virtual_origin_count); 11113 if computed_virtual_origin (i) = d -> dimension.virtual_origin 11114 then do; 11115 found = "1"b; 11116 return (d -> dimension.virtual_origin); 11117 end; 11118 end; 11119 11120 found = "0"b; 11121 if virtual_origin_count < hbound (computed_virtual_origin, 1) 11122 then do; 11123 virtual_origin_count = virtual_origin_count + 1; 11124 computed_virtual_origin (virtual_origin_count) = d -> dimension.virtual_origin; 11125 end; 11126 11127 return (d -> dimension.virtual_origin); 11128 11129 end get_virtual_origin; 11130 11131 free_array_ref: 11132 procedure (pt); 11133 11134 /* Frees an array_ref. The variable length and offset 11135* temporaries are also freed if necessary. */ 11136 11137 dcl (pt, p, t) pointer; 11138 dcl (a_ref, n) fixed binary (18); 11139 11140 p = pt; 11141 a_ref = fixed (rel (p), 18); 11142 11143 if get_ref_count (p) < 0 11144 then do; 11145 call print_message (415, a_ref); 11146 return; 11147 end; 11148 11149 if p -> array_ref.v_offset ^= 0 11150 then do; 11151 t = addr (rands (p -> array_ref.v_offset)); 11152 if t -> node.node_type = temporary_node 11153 then do; 11154 if analyzing 11155 then n, t -> temporary.ref_count_copy = t -> temporary.ref_count_copy - 1; 11156 else n, t -> temporary.ref_count = t -> temporary.ref_count - 1; 11157 if n <= 0 11158 then call free_temp (t); 11159 end; 11160 end; 11161 11162 if p -> array_ref.variable_length 11163 then do; 11164 t = addr (rands (p -> array_ref.length)); 11165 if t -> node.node_type = temporary_node 11166 then do; 11167 if analyzing 11168 then n, t -> temporary.ref_count_copy = t -> temporary.ref_count_copy - 1; 11169 else n, t -> temporary.ref_count = t -> temporary.ref_count - 1; 11170 if n <= 0 11171 then call free_temp (t); 11172 end; 11173 end; 11174 11175 call flush_ref (a_ref); 11176 call flush_addr (a_ref); 11177 call disconnect_temp (p); 11178 11179 p -> array_ref.dont_update = "1"b; 11180 11181 if p -> array_ref.output_by = 0 11182 then do; 11183 p -> array_ref.next = next_free_array_ref; 11184 next_free_array_ref = a_ref; 11185 end; 11186 11187 end free_array_ref; 11188 11189 /**** CONCATENATION CODE ****/ 11190 11191 start_cat: 11192 procedure (reallocated); 11193 11194 /* Expects the stack to contain all the concatenation operands. 11195* Computes the length of the result (emitting code if necessary), 11196* and allocates the temporary for the result (which is pushed on 11197* the stack.) The parameter reallocated is turned on in the case 11198* where the first operand of the concatenation is the most recently 11199* allocated dynamic temporary. (In this case the result temporary 11200* is merely an extension of the first operand). */ 11201 11202 dcl reallocated bit (1) aligned; /* (Output) */ 11203 11204 dcl alloc_length fixed binary (18); /* Total of operand lengths */ 11205 dcl result fixed binary (18); /* Result temporary (pushed on stack) */ 11206 dcl star_extent bit (1) aligned; /* On if any operand is of * extent */ 11207 dcl tv_offset fixed binary (14); /* Operator offset */ 11208 dcl i fixed binary; /* Loop variable */ 11209 11210 /* Get total of allocated lengths of operands. */ 11211 11212 alloc_length = 0; 11213 star_extent = "0"b; 11214 do i = (top - quad_ptr -> operator.number + 1) to (top - 1) while (^star_extent); 11215 alloc_length = alloc_length + get_cat_alloc_length ((stack (i)), star_extent); 11216 end; 11217 11218 if star_extent 11219 then do; 11220 11221 /* At least one of the operands was of star extent. A dynamic 11222* temporary is used for the result in this case. */ 11223 11224 reallocated = (stack (base) = current_ms.last_dynamic_temp); 11225 11226 if reallocated 11227 then tv_offset = reallocate_char_string; 11228 else tv_offset = allocate_char_string; 11229 11230 result = assign_dynamic_temp (); 11231 call assign_length_to_cat_result (result); 11232 call allocate_dynamic_temp (result, tv_offset); 11233 end; 11234 11235 else do; 11236 11237 /* No star extents are involved - use an ordinary temp */ 11238 11239 reallocated = "0"b; 11240 result = assign_char_temp (alloc_length); 11241 call assign_length_to_cat_result (result); 11242 end; 11243 11244 /* Initialize some variables that will be used as the concatenation 11245* continues. */ 11246 11247 cat_offset_temp = 0; 11248 saved_cat_address = addr (rands (result)) -> temporary.address; 11249 11250 call push (result); 11251 11252 end start_cat; 11253 11254 continue_cat: 11255 procedure (); 11256 11257 /* Adds the length of the most recently processed concatenation 11258* operand into the address of the result. The result is assumed 11259* to be at the base of the stack, and the most recently processed 11260* operand is assumed to be at the top. */ 11261 11262 dcl (p, p1) pointer; /* To result, operand */ 11263 dcl csize fixed binary (18); /* Length of operand */ 11264 dcl off fixed binary (18); /* Total char offset */ 11265 dcl regno fixed binary (3); /* Base register number */ 11266 11267 p = addr (rands (stack (base))); 11268 p1 = addr (rands (stack (top))); 11269 11270 csize = get_char_size (p1); 11271 if csize < 0 11272 then do; 11273 11274 /* Length of the operand is constant. Try adding the length 11275* to the address of the result, avoiding large address. */ 11276 11277 off = p -> temporary.address.char_num + (p -> temporary.address.offset * chars_per_word) + (csize + bias); 11278 if off < 16384 * chars_per_word 11279 then do; 11280 p -> temporary.address.char_num = mod (off, chars_per_word); 11281 if (off < 0) & (p -> temporary.address.char_num ^= 0) 11282 then p -> temporary.address.offset = divide (off, chars_per_word, 18, 0) - 1; 11283 else p -> temporary.address.offset = divide (off, chars_per_word, 18, 0); 11284 return; 11285 end; 11286 else csize = create_integer_constant (csize + bias); 11287 end; 11288 11289 /* The length will have to be kept in a register. We use the Q, 11290* so that the lengths of subsequent operands can be added. */ 11291 11292 if cat_offset_temp = 0 11293 then do; 11294 11295 /* This is the first operand length we have had to put in a 11296* register. Allocate a temporary to hold the variable offset 11297* and load the length into the Q. */ 11298 11299 cat_offset_temp = assign_temp (int_mode); 11300 if analyzing 11301 then addr (rands (cat_offset_temp)) -> temporary.ref_count_copy = 131071; 11302 else addr (rands (cat_offset_temp)) -> temporary.ref_count = 131071; 11303 call bump_count (csize, 1); 11304 call load (csize, in_q); 11305 call use_eaq (0, Q, 0); 11306 call in_reg (cat_offset_temp, in_q); 11307 end; 11308 11309 else do; 11310 11311 /* Add the operand length into the variable offset. */ 11312 11313 call load (cat_offset_temp, in_q); 11314 addr (rands (cat_offset_temp)) -> temporary.not_in_storage = "0"b; 11315 call bump_count (csize, 1); 11316 call emit_single (adfx1, csize); 11317 call in_reg (cat_offset_temp, in_q); 11318 addr (rands (cat_offset_temp)) -> temporary.not_in_storage = "1"b; 11319 end; 11320 11321 /* Prevent emit_eis from using the Q in addressing by reserving it. 11322* This is safe because at most one of the operands of the EIS 11323* instruction can have a large offset. */ 11324 11325 call lock_eaq (Q); 11326 p -> temporary.address.tag = p -> temporary.address.tag | QL_mod; 11327 11328 /* If the address of the result temporary is in a base register, 11329* prevent m_a from using it by pretending it is reserved. */ 11330 11331 if p -> temporary.address_in_base 11332 then do; 11333 regno = which_base (fixed (p -> temporary.address.base, 3)); 11334 current_ms.base_regs (regno).reserved = "1"b; 11335 end; 11336 11337 end continue_cat; 11338 11339 finish_cat: 11340 procedure (); 11341 11342 /* Restores the original address of the result temporary, and 11343* perform other cleanups now that the concatenation has been 11344* completely compiled. */ 11345 11346 addr (rands (stack (base))) -> temporary.address = saved_cat_address; 11347 11348 if cat_offset_temp ^= 0 11349 then call free_temp (addr (rands (cat_offset_temp))); 11350 11351 call free_regs (); 11352 11353 end finish_cat; 11354 11355 get_cat_alloc_length: 11356 procedure (opnd, star_extent) returns (fixed binary (18)); 11357 11358 /* Returns the allocation length of the character string operand 11359* opnd. If opnd is a star extent parameter, the star_extent bit 11360* is turned on. */ 11361 11362 dcl opnd fixed binary (18); /* Operand offset */ 11363 dcl star_extent bit (1) aligned; 11364 dcl p pointer; /* Pointer to operand */ 11365 dcl csize fixed binary (18); /* Character length */ 11366 11367 p = addr (rands (opnd)); 11368 11369 csize = get_char_size (p); 11370 if csize < 0 11371 then do; 11372 11373 /* Constant length */ 11374 11375 star_extent = "0"b; 11376 return (csize + bias); 11377 end; 11378 11379 /* If the operand is not of constant length, but is a substring or 11380* array reference whose parent is of constant length, return the 11381* parent's length as the length for allocation. */ 11382 11383 if p -> node.node_type = array_ref_node 11384 then do; 11385 csize = get_char_size (addr (rands (p -> array_ref.parent))); 11386 if csize < 0 11387 then do; 11388 star_extent = "0"b; 11389 return (csize + bias); 11390 end; 11391 end; 11392 11393 /* If the operand is a variable length temporary that is not of star 11394* extent, use the allocated length of the temporary. */ 11395 11396 else if p -> node.node_type = temporary_node 11397 then if ^p -> temporary.stack_indirect 11398 then do; 11399 star_extent = "0"b; 11400 return (p -> temporary.size * chars_per_word); 11401 end; 11402 11403 /* The operand must have been of star extent. */ 11404 11405 star_extent = "1"b; 11406 return (0); 11407 11408 end get_cat_alloc_length; 11409 11410 assign_length_to_cat_result: 11411 procedure (cat_result); 11412 11413 /* Puts the proper length onto the temporary which is the result of 11414* concatenation operator currently being compiled. The length is 11415* taken from the last operand of the cat_op. */ 11416 11417 dcl cat_result fixed binary (18); 11418 11419 dcl (length, result) pointer; 11420 11421 result = addr (rands (cat_result)); 11422 length = addr (rands (stack (top))); 11423 11424 if length -> node.operand_type = constant_type 11425 then do; 11426 11427 /* Length is constant, so put it right in the temporary */ 11428 11429 result -> temporary.length = addr (length -> constant.value) -> int_image; 11430 result -> temporary.variable_length = "0"b; 11431 end; 11432 11433 else do; 11434 11435 /* Length is not constant - chain it to the temporary */ 11436 11437 result -> temporary.length = stack (top); 11438 result -> temporary.variable_length = "1"b; 11439 end; 11440 11441 end assign_length_to_cat_result; 11442 11443 /**** DESCRIPTOR RELATED CODE ****/ 11444 11445 get_param_char_size: 11446 procedure (sym, arg_no); 11447 11448 /* This procedure generates code to extract the length of a 11449* star extent character string from the argument list 11450* descriptor and store it in the symbol.v_length variable 11451* allocated by the parse. Also, if the character string is 11452* passed as an argument and requires a descriptor of its own, 11453* code is generated to initialize the automatic descriptor 11454* from the template in the text section and to fill in the 11455* length field. */ 11456 11457 dcl (s, sym) pointer; 11458 dcl arg_no fixed binary (18); 11459 11460 dcl desc fixed binary (18); 11461 dcl mask fixed binary (18); /* mask off high bits of Q register */ 11462 11463 s = sym; 11464 desc = s -> symbol.hash_chain; 11465 11466 /* If there is a descriptor template node, but it has not been 11467* assigned storage, then it is only needed to build the entry 11468* point definitions and we can ignore it. */ 11469 11470 if desc ^= 0 11471 then if ^addr (rands (desc)) -> symbol.allocated 11472 then desc = 0; 11473 11474 /* Initialize the automatic descriptor if array */ 11475 11476 if desc ^= 0 & s -> symbol.dimensioned 11477 then call copy_array_desc_template (s); 11478 11479 /* Extract length from descriptor and store it in symbol.v_length */ 11480 11481 addr (rands (builtins (11))) -> symbol.location = 2 * arg_no - 2; 11482 call emit_single ((load_inst (in_q)), (builtins (11))); 11483 call emit_c_a (anq, descriptor_mask_addr); 11484 call emit_single ((store_inst (in_q)), (s -> symbol.v_length)); 11485 11486 /* Put length into automatic descriptor */ 11487 11488 if desc ^= 0 11489 then do; 11490 mask = create_constant (int_mode, "777700000000"b3); 11491 if s -> symbol.dimensioned 11492 then do; 11493 call emit_single (orq, mask); 11494 call emit_single (anq, desc); 11495 call emit_single (stq, desc); 11496 end; 11497 11498 else do; 11499 11500 /* Get type bits while we're at it */ 11501 call emit_single (orq, mask); 11502 call emit_single (anq, (addr (rands (desc)) -> symbol.general)); 11503 call emit_single ((store_inst (in_q)), desc); 11504 end; 11505 end; 11506 11507 call reset_eaq (Q); 11508 11509 end get_param_char_size; 11510 11511 copy_array_desc_template: 11512 procedure (sym); 11513 11514 /* Generates code to copy the descriptor template for an array 11515* from the text into automatic storage. */ 11516 11517 dcl (s, sym) pointer; 11518 dcl desc fixed binary (18); 11519 11520 s = sym; 11521 desc = s -> symbol.hash_chain; 11522 11523 call push ((addr (rands (desc)) -> symbol.general)); 11524 call push (desc); 11525 call interpreter_proc (move_eis, r3); 11526 r3: 11527 return; 11528 11529 end copy_array_desc_template; 11530 11531 make_descriptor: 11532 procedure (var) returns (fixed binary (18)); 11533 11534 /* Builds a descriptor for var, which must be either a temporary, 11535* an array reference, or a symbol of constant extent (variable- 11536* and star-extent symbols have been dealt with at storage 11537* allocation time.) If the temporary or arry_ref is a character 11538* string of star extent, code is emitted to fill in the length 11539* field of the descriptor. */ 11540 11541 dcl var fixed binary (18); /* argument that needs a descriptor */ 11542 dcl p pointer; 11543 dcl (desc, const, dt, csize) fixed binary (18); 11544 dcl v_length bit (1) aligned; 11545 11546 dcl 1 descriptor aligned, /* Scalars only */ 11547 2 type_word aligned, 11548 3 bit_type unaligned, 11549 4 flag bit (1) unaligned, 11550 4 type bit (6) unaligned, 11551 4 packed bit (1) unaligned, 11552 3 number_dims fixed binary (3) unaligned, 11553 3 size fixed binary (23) unaligned; 11554 11555 p = addr (rands (var)); 11556 unspec (descriptor) = "0"b; 11557 v_length = "0"b; 11558 11559 /* Handle symbols */ 11560 11561 if p -> node.node_type = symbol_node 11562 then if p -> symbol.hash_chain ^= 0 11563 then return (p -> symbol.hash_chain); 11564 else return (make_symbol_descriptor ((var))); 11565 11566 /* Initialize the descriptor's type word */ 11567 11568 if p -> node.operand_type >= bif 11569 then unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, 7)); 11570 else do; 11571 dt = p -> node.data_type; 11572 unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, dt)); 11573 if dt = char_mode 11574 then do; 11575 if p -> node.units = char_units 11576 then descriptor.packed = "1"b; 11577 csize = get_char_size (p); 11578 if csize < 0 11579 then descriptor.size = csize + bias; 11580 else v_length = "1"b; 11581 end; 11582 end; 11583 11584 /* Create a constant node for the descriptor */ 11585 11586 const = create_constant (int_mode, unspec (descriptor.type_word)); 11587 11588 /* If the descriptor must be filled in at runtime, allocate a 11589* temporary for it, and emit code to initialize it. */ 11590 11591 if v_length 11592 then do; 11593 desc = assign_temp (int_mode); 11594 if analyzing 11595 then addr (rands (desc)) -> temporary.ref_count_copy = 131071; 11596 else addr (rands (desc)) -> temporary.ref_count = 131071; 11597 call load (get_char_size (p), in_q); 11598 call emit_c_a (anq, descriptor_mask_addr); 11599 call emit_single (orq, const); 11600 call emit_single (store_inst (in_q), desc); 11601 call reset_eaq (Q); 11602 11603 /* Chain this descriptor so that it can be freed after 11604* the call has been compiled. */ 11605 11606 addr (rands (desc)) -> temporary.next = desc_temp_chain; 11607 desc_temp_chain = desc; 11608 end; 11609 else desc = const; 11610 11611 return (desc); 11612 11613 end make_descriptor; 11614 11615 set_itp_addr: 11616 procedure (pt, pos); 11617 11618 /* Sets one element of an ITP list to contain the 11619* address of the operand pointed to by pt. */ 11620 11621 dcl (pt, p) pointer; 11622 dcl (pos, i) fixed binary (18); 11623 11624 p = pt; 11625 i = pos; 11626 11627 string (itp_list (i)) = "0"b; 11628 11629 if p -> node.ext_base 11630 then do; 11631 itp_list (i).pr_no = p -> node.base; 11632 itp_list (i).itp_mod = ITP_mod; 11633 itp_list (i).offset = bit (fixed (p -> node.address.offset, 18), 18); 11634 itp_list (i).bit_offset = bit (fixed (p -> node.address.char_num * bits_per_char, 6), 6); 11635 11636 /* Fix bug344 - stack_indirect ITP needs RI (*n) indirect modification */ 11637 11638 if p -> node.stack_indirect 11639 then itp_list (i).mod = RI_mod; 11640 end; 11641 else addr (itp_list (i)) -> ind_word = unspec (p -> node.address); 11642 11643 end set_itp_addr; 11644 11645 check_arg_list: 11646 procedure (); 11647 11648 /* Checks argument lists for consistency, using subprogram 11649* definition if possible otherwise using the first invoction 11650* of each subprogram as a model for checking. If the call is 11651* to an external (descriptors) procedure, consistency is not 11652* checked, but assumed size arrays as arguments are diagnosed. 11653* The stack looks like: 11654* 11655* external reference 11656* count 11657* arg1 11658* arg2 11659* . 11660* . 11661* . 11662* argn 11663* */ 11664 11665 dcl (adesc, i) fixed binary (18); 11666 dcl (a, p, s) pointer; 11667 11668 num_args = stack (base + 1) + bias; 11669 s = addr (rands (stack (base))); 11670 11671 if s -> symbol.variable_arglist 11672 then do; 11673 11674 /* Must diagnose assumed size arrays as arguments */ 11675 11676 do i = 1 to num_args; 11677 p = addr (rands (stack (base + i + 1))); 11678 if p -> node.node_type = symbol_node 11679 then if p -> symbol.dimensioned 11680 then if addr (rands (p -> symbol.dimension)) -> dimension.assumed_size 11681 then call print_message (468, stack (base), stack (base + i + 1)); 11682 end; 11683 end; 11684 11685 else do; 11686 if s -> symbol.general = 0 11687 then call find_arg_desc (s); 11688 if s -> symbol.general = 0 11689 then do; /* couldn't find arg_desc node, probably an external procedure */ 11690 11691 /* first time, set up arg_desc structure */ 11692 11693 11694 adesc, s -> symbol.general = create_node (arg_desc_node, size (arg_desc)); 11695 a = addr (rands (adesc)); 11696 a -> arg_desc.n_args = num_args; 11697 11698 do i = 1 to num_args; 11699 p = addr (rands (stack (base + i + 1))); 11700 a -> arg_desc.data_type (i) = p -> node.data_type; 11701 if p -> node.node_type = symbol_node 11702 then if p -> symbol.dimensioned 11703 then do; 11704 a -> arg_desc.must_be.array (i) = "1"b; 11705 if p -> symbol.ext_attributes.VLA 11706 then a -> arg_desc.must_be.VLA (i) = "1"b; 11707 end; 11708 else a -> arg_desc.must_be.scalar (i) = "1"b; 11709 else if p -> node.node_type ^= array_ref_node 11710 then a -> arg_desc.must_be.scalar (i) = "1"b; 11711 end; 11712 end; 11713 11714 else do; 11715 11716 /* not the first time, compare args with arg_desc structure */ 11717 11718 a = addr (rands (s -> symbol.general)); 11719 11720 if num_args ^= a -> arg_desc.n_args 11721 then do; 11722 call print_message (400, stack (base)); 11723 if num_args > a -> arg_desc.n_args 11724 then num_args = a -> arg_desc.n_args; 11725 end; 11726 11727 do i = 1 to num_args; 11728 p = addr (rands (stack (base + i + 1))); 11729 11730 /* When a program calls an internal subroutine with arguments 11731* that are declared as different data types in the included 11732* routine, it will raise an error except in the case of 11733* passing a character constant. */ 11734 11735 if (p -> node.node_type ^= char_constant_node) 11736 then do; 11737 if (p -> node.data_type ^= a -> arg_desc.data_type (i)) 11738 & 11739 ^(p -> node.node_type = temporary_node 11740 & addr (rands (a -> arg_desc.arg (i).symbol)) -> symbol.external) 11741 then call bad_arg; 11742 11743 else if p -> node.node_type = symbol_node 11744 then do; 11745 if p -> symbol.dimensioned 11746 then do; 11747 if a -> arg_desc.must_be.scalar (i) 11748 then call bad_arg; 11749 else if p -> symbol.ext_attributes.VLA 11750 then if ^a -> arg_desc.must_be.VLA (i) 11751 then call bad_arg; 11752 end; 11753 else if a -> arg_desc.must_be.array (i) 11754 then call bad_arg; 11755 end; 11756 else if p -> node.node_type ^= array_ref_node 11757 then if a -> arg_desc.must_be.array (i) 11758 then call bad_arg; 11759 end; 11760 end; 11761 end; 11762 end; 11763 11764 11765 bad_arg: 11766 procedure (); 11767 11768 call print_message (401, stack (base + i + 1), stack (base)); 11769 11770 end bad_arg; 11771 11772 /* This procedure finds an arg_desc node that corresponds to an entry node. 11773* It looks up the entry node that corresponds to the actual declaration of 11774* a subprogram (if one exists), and looks in its symbol.general field to 11775* find its arg_desc node. It returns the location of the arg_desc node by 11776* setting the referencing entry node's general field. It also makes sure 11777* that the arg_desc node contains the data_type associated with each 11778* parameter. */ 11779 find_arg_desc: 11780 proc (sp); 11781 dcl (e, i, ii) fixed bin; 11782 dcl (sp, ap, ep, symp) ptr; 11783 11784 /* find the entry node with the same name */ 11785 e = shared_globals.first_entry_name; 11786 do while (addr (rands (e)) -> symbol.name ^= sp -> symbol.name & e ^= shared_globals.last_entry_name); 11787 e = addr (rands (e)) -> symbol.next_symbol; 11788 end; 11789 ep = addr (rands (e)); 11790 11791 if ep -> symbol.name ^= sp -> symbol.name 11792 then return; /* couldn't find it */ 11793 if ep -> symbol.general = 0 11794 then return; /* no arg_desc node */ 11795 11796 sp -> symbol.general = ep -> symbol.general; 11797 11798 /* make sure that the data_type fields are set. If there are any * arguments 11799* (indicated by there being no symbol node accociated with the argument), then 11800* remove all of these args and place one * arg at the end of the list. Set 11801* its data_type to 1. */ 11802 11803 ap = addr (rands (ep -> symbol.general)); 11804 ii = 1; 11805 do i = 1 to ap -> arg_desc.n_args; 11806 if ap -> arg_desc.arg (i).symbol ^= 0 11807 then do; 11808 ap -> arg_desc.arg (ii) = ap -> arg_desc.arg (i); 11809 if ap -> arg_desc.arg (ii).data_type = 0 11810 then do; 11811 symp = addr (rands (ap -> arg_desc.arg (ii).symbol)); 11812 ap -> arg_desc.arg (ii).data_type = symp -> symbol.data_type; 11813 if symp -> node.node_type = symbol_node 11814 then if symp -> symbol.dimensioned 11815 then do; 11816 ap -> arg_desc.arg (ii).must_be.array = "1"b; 11817 if symp -> symbol.ext_attributes.VLA 11818 then ap -> arg_desc.must_be.VLA (ii) = "1"b; 11819 end; 11820 else ap -> arg_desc.arg (ii).must_be.scalar = "1"b; 11821 else if symp -> node.node_type ^= array_ref_node 11822 then ap -> arg_desc.arg (ii).must_be.scalar = "1"b; 11823 end; 11824 ii = ii + 1; 11825 end; 11826 end; 11827 if ii ^= i 11828 then do; 11829 11830 /* at least one asterisk arg was removed */ 11831 11832 ap -> arg_desc.n_args = ii; 11833 unspec (ap -> arg_desc.arg (ii)) = "0"b; 11834 ap -> arg_desc.arg (ii).data_type = 1; 11835 end; 11836 end find_arg_desc; 11837 11838 end check_arg_list; 11839 11840 replace_inputs: 11841 procedure (old_input, new_input); 11842 11843 dcl old_input fixed binary (18); /* Existing temp */ 11844 dcl new_input fixed binary (18); /* Replacement */ 11845 11846 dcl (new, i) fixed binary (18); 11847 dcl input pointer; 11848 11849 new = new_input; 11850 11851 i = addr (rands (old_input)) -> temporary.start_input_to; 11852 if i = 0 11853 then return; 11854 11855 do input = addr (polish (i)) repeat (input -> input_to.next) while (input ^= null ()); 11856 if input -> input_to.which > 0 /* Operand number */ 11857 then input -> input_to.operator -> operator.operand (input -> input_to.which) = new; 11858 else if input -> input_to.which = 0 /* Output temp */ 11859 then input -> input_to.operator -> operator.output = new; 11860 end; 11861 11862 end replace_inputs; 11863 11864 /**** REGISTER USAGE ANALYSIS -- End of flow_unit, End of loop processing. ****/ 11865 11866 reset_scan: 11867 procedure (cur_statement, statement_ptr, iquad, fu, cur_lp); 11868 11869 /* Resets scanners at end of flow_unit. May do end_of_loop processing. */ 11870 11871 dcl cur_statement fixed binary (18), /* Current statement */ 11872 statement_ptr pointer, /* addr(quad(cur_statement)) */ 11873 iquad fixed binary (18), /* Next operator to be scanned */ 11874 fu pointer, /* flow_unit being processed */ 11875 cur_lp pointer; /* Loop being processed */ 11876 11877 dcl (next_lp, last_fu, next_stm) pointer; 11878 11879 11880 if fu -> flow_unit.next_in_loop ^= fu -> flow_unit.next 11881 then do; 11882 11883 /* We are either about to pass over flow_units from other 11884* loops, or have processed the last flow_unit of this loop. */ 11885 11886 if fu -> flow_unit.falls_through 11887 then do; 11888 next_lp = fu -> flow_unit.next -> flow_unit.loop; 11889 11890 if cur_lp -> loop.depth < next_lp -> loop.depth 11891 then call flush_state; 11892 else do; 11893 next_stm = addr (quad (fu -> flow_unit.next -> flow_unit.first_statement)); 11894 if ^next_stm -> opt_statement.referenced_backwards 11895 & ^next_stm -> opt_statement.referenced_by_assign 11896 then call save_state (get_label (next_stm)); 11897 call discard_state; 11898 end; 11899 end; 11900 end; 11901 11902 if fu -> flow_unit.next_in_loop ^= null 11903 then do; 11904 11905 /* We have another flow_unit in this loop, 11906* so initialize for the next flow_unit. */ 11907 11908 last_fu = fu; 11909 fu = fu -> flow_unit.next_in_loop; 11910 11911 if last_fu ^= fu -> flow_unit.back 11912 then do; 11913 11914 /* We have passed over flow_units from other loops. */ 11915 11916 if ^fu -> flow_unit.back -> flow_unit.falls_through 11917 then call discard_state; 11918 else if ^state_discarded 11919 then if next_lp ^= fu -> flow_unit.back -> flow_unit.loop 11920 then call discard_state; 11921 end; 11922 end; 11923 11924 else do; 11925 11926 /* We've finished this loop. */ 11927 11928 call allocate_registers; 11929 11930 string (cur_lp -> loop.father -> loop.erases) = 11931 string (cur_lp -> loop.father -> loop.erases) | string (cur_lp -> loop.erases); 11932 string (cur_lp -> loop.father -> loop.avoid_pr) = 11933 string (cur_lp -> loop.father -> loop.avoid_pr) | string (cur_lp -> loop.avoid_pr); 11934 11935 call reset_global_data; 11936 11937 do i_loop = i_loop + 1 to n_loops - 1 while (loop_vector (i_loop) -> loop.members = null); 11938 end; 11939 11940 if i_loop >= n_loops 11941 then do; 11942 iquad = cs -> subprogram.last_quad; 11943 return; 11944 end; 11945 11946 cur_lp = loop_vector (i_loop); 11947 fu = cur_lp -> loop.members; 11948 call discard_state; 11949 end; 11950 11951 cur_statement = fu -> flow_unit.first_statement; 11952 statement_ptr = addr (quad (cur_statement)); 11953 iquad = statement_ptr -> opt_statement.first_operator; 11954 11955 end reset_scan; 11956 11957 get_label: 11958 procedure (st) returns (fixed binary (18)); 11959 11960 /* Returns label attached to a statement. Creates, if not found. */ 11961 11962 dcl st pointer; 11963 11964 dcl lbl fixed binary (18); 11965 11966 lbl = st -> opt_statement.label; 11967 11968 if lbl = 0 11969 then do; 11970 lbl, st -> opt_statement.label = create_rel_constant (cs); 11971 addr (rands (lbl)) -> label.statement = fixed (rel (st), 18); 11972 end; 11973 11974 return (lbl); 11975 11976 end get_label; 11977 11978 reset_global_data: 11979 procedure (); 11980 11981 /* Resets info in ptr_data and index_data */ 11982 11983 dcl p pointer; 11984 11985 ptr_data.local, ptr_data.max_local, ptr_data.locked, ptr_data.max_locked = 0; 11986 11987 do while (ptr_data.n_global > 0); 11988 p = ptr_data.item (ptr_data.n_global); 11989 p -> pointer.count = 0; 11990 ptr_data.n_global = ptr_data.n_global - 1; 11991 end; 11992 11993 index_data.local, index_data.max_local, index_data.locked, index_data.max_locked = 0; 11994 11995 do while (index_data.n_global > 0); 11996 p = index_data.item (index_data.n_global); 11997 p -> node.loop_ref_count = 0; 11998 index_data.n_global = index_data.n_global - 1; 11999 end; 12000 12001 end reset_global_data; 12002 12003 /**** GLOBAL REGISTER ALLOCATION ****/ 12004 12005 allocate_registers: 12006 procedure (); 12007 12008 dcl p pointer; 12009 dcl (i, n_allocated) fixed binary; 12010 12011 /* Sort the global register items. */ 12012 12013 call sort_globals (ptr_data.item_st, ptr_data.n_global, BASE); 12014 call sort_globals (index_data.item_st, index_data.n_global, INDEX); 12015 12016 /* Initialize the regs_used fields. */ 12017 12018 cur_lp -> loop.xregs_used = 12019 max (index_data.max_local, index_data.max_locked, fixed (index_data.n_global > avail_xregs, 1)); 12020 cur_lp -> loop.pregs_used = 12021 max (ptr_data.max_local, ptr_data.max_locked, fixed (ptr_data.n_global > avail_pregs, 1)); 12022 12023 /* Process the globals in descending order. */ 12024 12025 do i = 1 to ptr_data.n_global while (cur_lp -> loop.pregs_used < avail_pregs); 12026 p = ptr_data.item (i); 12027 if ok_to_allocate (p, cur_lp, BASE) 12028 then do; 12029 call allocate (p, cur_lp, BASE); 12030 cur_lp -> loop.pregs_used = cur_lp -> loop.pregs_used + 1; 12031 end; 12032 end; 12033 12034 n_allocated = 0; 12035 12036 do i = 1 to index_data.n_global while (cur_lp -> loop.xregs_used < avail_xregs); 12037 p = index_data.item (i); 12038 if ok_to_allocate (p, cur_lp, INDEX) 12039 then do; 12040 call allocate (p, cur_lp, INDEX); 12041 cur_lp -> loop.xregs_used = cur_lp -> loop.xregs_used + 1; 12042 n_allocated = n_allocated + 1; 12043 end; 12044 end; 12045 12046 if n_allocated = avail_xregs 12047 then cur_lp -> loop.all_xrs_globally_assigned = "1"b; 12048 12049 return; 12050 12051 sort_globals: 12052 procedure (item_st, n_items, p_reg_type); 12053 12054 /* Sorts global items in descending order by count of uses in the loop. */ 12055 12056 dcl 1 item_st like ptr_data.item_st aligned; 12057 dcl n_items fixed binary; 12058 dcl (reg_type, p_reg_type) fixed binary; /* INDEX, BASE */ 12059 12060 dcl (d, i, j, k) fixed binary; 12061 dcl (p1, p2, p) pointer; 12062 12063 reg_type = p_reg_type; 12064 12065 d = n_items; 12066 12067 do while (d > 1); 12068 d = 2 * divide (d, 4, 17, 0) + 1; 12069 12070 do i = 1 to n_items - d; 12071 k = i + d; 12072 p2 = item (k); 12073 up: 12074 j = k - d; 12075 p1 = item (j); 12076 12077 if less_than (p1, p2, reg_type) 12078 then do; 12079 p = item (j); 12080 item (j) = item (k); 12081 item (k) = p; 12082 12083 if j > d 12084 then do; 12085 k = j; 12086 go to up; 12087 end; 12088 end; 12089 end; 12090 end; 12091 12092 return; 12093 12094 less_than: 12095 procedure (p1, p2, reg_type) returns (bit (1) aligned); 12096 12097 dcl (p1, p2) pointer; 12098 dcl reg_type fixed binary; /* INDEX, BASE */ 12099 12100 if reg_type = INDEX 12101 then return (p1 -> node.loop_ref_count < p2 -> node.loop_ref_count); 12102 else return (p1 -> pointer.count < p2 -> pointer.count); 12103 12104 end less_than; 12105 12106 end sort_globals; 12107 12108 ok_to_allocate: 12109 procedure (pt, p_adam, p_reg_type) returns (bit (1) aligned); 12110 12111 /* Determines if it is ok to allocate a global item across inner loops. */ 12112 12113 dcl (p, pt) pointer, /* -> global item */ 12114 (adam, p_adam) pointer, /* -> loop */ 12115 (reg_type, p_reg_type) fixed binary; /* INDEX, BASE */ 12116 12117 dcl lp pointer; 12118 12119 adam = p_adam; 12120 12121 if adam -> loop.son = null 12122 then return ("1"b); 12123 12124 p = pt; 12125 reg_type = p_reg_type; 12126 12127 /* Simulate a recursive walk across the loop nest. */ 12128 12129 lp = adam -> loop.son; 12130 12131 do while ("1"b); 12132 if reg_type = INDEX 12133 then if ^ok ((lp -> loop.xregs_used), avail_xregs, (lp -> loop.global_xr_items)) 12134 then return ("0"b); 12135 else ; 12136 else if ^ok ((lp -> loop.pregs_used), avail_pregs, (lp -> loop.global_pr_items)) 12137 then return ("0"b); 12138 12139 if lp -> loop.son ^= null 12140 then lp = lp -> loop.son; 12141 12142 else do; 12143 do while (lp -> loop.brother = null); 12144 lp = lp -> loop.father; 12145 if lp = adam 12146 then return ("1"b); 12147 end; 12148 12149 lp = lp -> loop.brother; 12150 end; 12151 end; 12152 12153 stop; 12154 12155 ok: 12156 procedure (regs_used, avail_regs, item_chain) returns (bit (1) aligned); 12157 12158 dcl regs_used fixed binary (4), 12159 avail_regs fixed binary (4), 12160 item_chain pointer; 12161 12162 dcl c pointer; 12163 dcl found bit (1) aligned; 12164 12165 if regs_used >= avail_regs 12166 then do; 12167 found = "0"b; 12168 do c = item_chain repeat c -> chain.next while (^found & c ^= null); 12169 if p = c -> chain.value 12170 then found = "1"b; 12171 end; 12172 12173 if ^found 12174 then return ("0"b); 12175 end; 12176 12177 return ("1"b); 12178 12179 end ok; 12180 12181 end ok_to_allocate; 12182 12183 allocate: 12184 procedure (pt, p_adam, p_reg_type); 12185 12186 /* Allocate a global item across a loop next. */ 12187 12188 dcl (p, pt) pointer, /* -> global item */ 12189 (adam, p_adam) pointer, /* -> loop */ 12190 (reg_type, p_reg_type) fixed binary; /* INDEX, BASE */ 12191 12192 dcl (opnd, new_opnd) fixed binary (18); 12193 12194 dcl (bt, c, list_head, lp) pointer; 12195 dcl (op, op_code) fixed binary (18); 12196 dcl n fixed binary; 12197 12198 p = pt; 12199 adam = p_adam; 12200 reg_type = p_reg_type; 12201 bt = adam -> loop.back_target; 12202 opnd = fixed (rel (p), 18); 12203 12204 /* First, allocate in adam. */ 12205 12206 c = create_chain (); 12207 c -> chain.value = p; 12208 12209 if reg_type = INDEX 12210 then do; 12211 n = 2; 12212 c -> chain.next = adam -> loop.global_xr_items; 12213 adam -> loop.global_xr_items = c; 12214 op_code = load_xreg_op; 12215 call check_comparisons_and_increments (opnd, adam); 12216 call propagate_and_eliminate_assignment (opnd, adam, new_opnd); 12217 end; 12218 12219 else do; 12220 n = 1; 12221 c -> chain.next = adam -> loop.global_pr_items; 12222 adam -> loop.global_pr_items = c; 12223 op_code = load_preg_op; 12224 end; 12225 12226 op, bt -> flow_unit.insert_operator = insert_operator_after (op_code, n, (bt -> flow_unit.insert_operator)); 12227 call connect_expression (opnd, op, 1); 12228 12229 if n = 2 12230 then call connect_expression (new_opnd, op, 2); 12231 12232 /* Now, allocate in inner loops. */ 12233 12234 if adam -> loop.son ^= null 12235 then do; 12236 lp = adam -> loop.son; 12237 12238 do while ("1"b); 12239 if reg_type = INDEX 12240 then do; 12241 list_head = lp -> loop.global_xr_items; 12242 call alloc_inner (list_head, lp -> loop.xregs_used, n); 12243 lp -> loop.global_xr_items = list_head; 12244 if n = avail_xregs 12245 then lp -> loop.all_xrs_globally_assigned = "1"b; 12246 end; 12247 else do; 12248 list_head = lp -> loop.global_pr_items; 12249 call alloc_inner (list_head, lp -> loop.pregs_used, n); 12250 lp -> loop.global_pr_items = list_head; 12251 end; 12252 12253 if lp -> loop.son ^= null 12254 then lp = lp -> loop.son; 12255 12256 else do; 12257 do while (lp -> loop.brother = null); 12258 lp = lp -> loop.father; 12259 if lp = adam 12260 then return; 12261 end; 12262 12263 lp = lp -> loop.brother; 12264 end; 12265 end; 12266 end; 12267 12268 return; 12269 12270 alloc_inner: 12271 procedure (list_head, regs_used, n_allocated); 12272 12273 dcl list_head pointer, 12274 regs_used fixed binary (4), 12275 n_allocated fixed binary; /* (output) */ 12276 12277 dcl c pointer; 12278 12279 n_allocated = 1; 12280 12281 do c = list_head repeat c -> chain.next while (c ^= null); 12282 if c -> chain.value = p 12283 then return; 12284 n_allocated = n_allocated + 1; 12285 end; 12286 12287 regs_used = regs_used + 1; 12288 c = create_chain (); 12289 c -> chain.value = p; 12290 c -> chain.next = list_head; 12291 list_head = c; 12292 12293 end alloc_inner; 12294 12295 end allocate; 12296 12297 check_comparisons_and_increments: 12298 procedure (p_opnd, p_cur_lp); 12299 12300 /* If opnd is an induction variable, we check to see if it is compared 12301* against a non_constant. If it is, that non_constant must be left 12302* shifted 18 for the comparison. */ 12303 12304 dcl (opnd, p_opnd) fixed binary (18), /* Induction variable? */ 12305 (cur_lp, p_cur_lp) pointer; /* -> current loop */ 12306 12307 dcl (bt, c, non_const_p, lp, o, outp, p, lsc, lsp, t, stp) pointer; 12308 dcl (i_non_const, non_constant, ls_op) fixed binary (18); 12309 dcl i fixed binary; 12310 dcl found bit (1) aligned; 12311 12312 12313 cur_lp = p_cur_lp; 12314 opnd = p_opnd; 12315 p = addr (rands (opnd)); 12316 12317 if p -> node.node_type = symbol_node 12318 then if p -> symbol.coordinate > 0 12319 then if substr (cur_lp -> loop.induction_var -> bits, p -> symbol.coordinate, 1) 12320 then do c = cur_lp -> loop.eligible_ind_var_op_var repeat c -> chain.next while (c ^= null); 12321 o = c -> chain.value; 12322 12323 found = "0"b; 12324 12325 if o -> operator.op_code = storage_add_op | o -> operator.op_code = neg_storage_add_op 12326 then if o -> operator.output = opnd 12327 then do; 12328 found = "1"b; 12329 i_non_const = 1; 12330 end; 12331 else ; 12332 12333 else do; 12334 do i = 1 to 2 while (o -> operator.operand (i) ^= opnd); 12335 end; 12336 12337 if i <= 2 12338 then do; 12339 found = "1"b; 12340 i_non_const = 3 - i; 12341 end; 12342 end; 12343 12344 if found 12345 then do; 12346 12347 /* Found such a comparison, now find the outermost loop in 12348* which the non_constant is invariant. */ 12349 12350 non_constant = o -> operator.operand (i_non_const); 12351 12352 do lp = cur_lp repeat lp -> loop.father 12353 while (lp -> loop.father -> loop.back_target ^= null 12354 & is_invariant_in (non_constant, (lp -> loop.father))); 12355 end; 12356 12357 bt = lp -> loop.back_target; 12358 12359 /* Now find out if there is already a left shift of the 12360* non_constant to be commoned. */ 12361 12362 found = "0"b; 12363 lsc = lp -> loop.left_shift_chain; 12364 do while (^found & lsc ^= null); 12365 if lsc -> chain.value -> operator.operand (1) = non_constant 12366 then found = "1"b; 12367 else lsc = lsc -> chain.next; 12368 end; 12369 12370 if ^found 12371 then do; 12372 12373 /* We must create a left_shift of the non_constant . */ 12374 12375 ls_op, bt -> flow_unit.insert_operator = 12376 insert_operator_after (mult_op, 2, (bt -> flow_unit.insert_operator)); 12377 lsp = addr (quad (ls_op)); 12378 12379 call connect_expression (non_constant, ls_op, 1); 12380 lsp -> operator.operand (2) = create_integer_constant (262144); 12381 lsp -> operator.output = create_integer_temporary (ls_op); 12382 12383 /* Stick in loop_end list. */ 12384 12385 call put_in_loop_end (addr (rands (lsp -> operator.output)), lp); 12386 12387 if ^bt -> flow_unit.falls_through 12388 then do; 12389 12390 /* The back target ends with a jump_op. The 12391* target of the jump is the first statement 12392* in the loop entry unit. Add the left shift 12393* to the operator list of that statement, to 12394* ensure that the shifted value is stored 12395* before the loop is entered. */ 12396 12397 stp = addr (quad (lp -> loop.entry_unit -> flow_unit.first_statement)); 12398 12399 t = get_opt_space (size (primary)); 12400 t -> primary.last = null (); 12401 t -> primary.next = stp -> opt_statement.operator_list; 12402 stp -> opt_statement.operator_list = t; 12403 12404 if t -> primary.next ^= null () 12405 then t -> primary.next -> primary.last = t; 12406 else stp -> opt_statement.has_operator_list = "1"b; 12407 12408 t -> primary.expression = lsp; 12409 t -> primary.flow_unit = bt; 12410 end; 12411 12412 /* Stick in left_shift chain. */ 12413 12414 lsc = create_chain (); 12415 lsc -> chain.value = lsp; 12416 lsc -> chain.next = lp -> loop.left_shift_chain; 12417 lp -> loop.left_shift_chain = lsc; 12418 end; 12419 12420 else lsp = lsc -> chain.value; 12421 12422 /* Now replace the non_constant. */ 12423 12424 non_const_p = addr (rands (non_constant)); 12425 if non_const_p -> node.node_type = temporary_node 12426 then do; 12427 call disconnect_temporary (non_const_p, o); 12428 12429 /* make up for the fact that we already have scanned 12430* non_const_p, but won't during CG */ 12431 12432 non_const_p -> temporary.ref_count_copy = 12433 non_const_p -> temporary.ref_count_copy + 1; 12434 end; 12435 12436 call connect_expression ((lsp -> operator.output), fixed (rel (o), 18), i_non_const); 12437 12438 /* since we won't scan operator.output in this loop, 12439* decrement its ref_count, accordingly */ 12440 12441 outp = addr (rands (lsp -> operator.output)); 12442 outp -> temporary.ref_count_copy = outp -> temporary.ref_count_copy - 1; 12443 end; 12444 end; 12445 12446 end check_comparisons_and_increments; 12447 12448 propagate_and_eliminate_assignment: 12449 procedure (p_opnd, p_lp, new_opnd); 12450 12451 /* If opnd is assigned a constant or symbol value in lp's back target, 12452* we attempt to remove the assignment and return the value in new_opnd 12453* for loading into an xreg. */ 12454 12455 dcl (p_opnd, opnd) fixed binary (18), /* operand to be loaded into an xreg */ 12456 (p_lp, lp) pointer, /* -> loop node */ 12457 new_opnd fixed binary (18); /* operand to actually be loaded */ 12458 12459 dcl (bt, inp, o, p) pointer; 12460 dcl (c, first_stm, i, op) fixed binary (18); 12461 dcl in_common bit (1) aligned; 12462 12463 lp = p_lp; 12464 bt = lp -> loop.back_target; 12465 opnd = p_opnd; 12466 new_opnd = opnd; 12467 p = addr (rands (opnd)); 12468 12469 if p -> node.node_type = symbol_node 12470 then do; 12471 c = p -> symbol.coordinate; 12472 12473 if ^substr (lp -> loop.busy_on_exit -> bits, c, 1) & substr (lp -> loop.induction_var -> bits, c, 1) 12474 & substr (bt -> flow_unit.set -> bits, c, 1) 12475 then do; 12476 in_common = p -> symbol.in_common; 12477 12478 /* loop backwards through operators looking for uses and sets */ 12479 12480 first_stm = bt -> flow_unit.first_statement; 12481 12482 do op = bt -> flow_unit.insert_operator repeat o -> operator.back while (op ^= first_stm); 12483 o = addr (quad (op)); 12484 12485 /* special handling for namelist and common */ 12486 12487 if o -> operator.op_code = read_namelist_op | o -> operator.op_code = write_namelist_op 12488 then if in_namelist (o, opnd) 12489 then return; 12490 else ; 12491 else if in_common 12492 then if o -> operator.op_code = func_ref_op | o -> operator.op_code = call_op 12493 then return; 12494 12495 /* look for uses */ 12496 12497 do i = 1 to o -> operator.number; 12498 if o -> operator.operand (i) = opnd 12499 then return; 12500 end; 12501 12502 /* look for set */ 12503 12504 if o -> operator.output = opnd 12505 then do; 12506 if o -> operator.op_code = assign_op 12507 then do; 12508 inp = addr (rands (o -> operator.operand (1))); 12509 if inp -> node.node_type = constant_node 12510 then call eliminate (); 12511 else if inp -> node.node_type = symbol_node 12512 then do; 12513 12514 /* If the input symbol might be set later in the flow unit, 12515* this assignment cannot be eliminated because the 12516* RHS may not be the correct value when the loop 12517* is entered. */ 12518 12519 if inp -> symbol.aliasable 12520 then return; /* Punt */ 12521 12522 if substr (bt -> flow_unit.set -> bits, inp -> symbol.coordinate, 1) 12523 then return; 12524 12525 call eliminate (); 12526 end; 12527 end; 12528 return; 12529 end; 12530 end; 12531 end; 12532 end; 12533 12534 eliminate: 12535 procedure (); 12536 12537 /* This procedure does the actual elimination of assignments for 12538* propagate_and_eliminate_assignment. */ 12539 12540 if op = bt -> flow_unit.insert_operator 12541 then bt -> flow_unit.insert_operator = o -> operator.back; 12542 12543 new_opnd = o -> operator.operand (1); 12544 12545 call unthread (o); 12546 12547 if ^substr (bt -> flow_unit.set_multiple -> bits, c, 1) 12548 then substr (bt -> flow_unit.set -> bits, c, 1) = "0"b; 12549 12550 end eliminate; 12551 12552 end propagate_and_eliminate_assignment; 12553 12554 end allocate_registers; 12555 12556 insert_operator_after: 12557 procedure (op_code, number, last_operator) returns (fixed binary (18)); 12558 12559 dcl op_code fixed binary (18), 12560 number fixed binary, 12561 last_operator fixed binary (18); 12562 12563 dcl (o, next_o, last_o) pointer; 12564 dcl op fixed binary (18); 12565 12566 /* Allocate the space. */ 12567 12568 n_operands = number; 12569 op = get_quad_space (size (operator)); 12570 o = addr (quad (op)); 12571 12572 /* Initialize the space. */ 12573 12574 o -> operator.op_code = op_code; 12575 o -> operator.number = n_operands; 12576 o -> operator.assigns_constant_to_symbol, o -> operator.freed = "0"b; 12577 o -> operator.primary = null; 12578 12579 /* Insert the operator. */ 12580 12581 last_o = addr (quad (last_operator)); 12582 next_o = addr (quad (last_o -> operator.next)); 12583 o -> operator.next = last_o -> operator.next; 12584 o -> operator.back = last_operator; 12585 last_o -> operator.next = op; 12586 next_o -> operator.back = op; 12587 12588 return (op); 12589 12590 end insert_operator_after; 12591 12592 create_integer_temporary: 12593 procedure (op) returns (fixed binary (18)); 12594 12595 dcl op fixed binary (18); /* Operator producing the temp */ 12596 12597 dcl t pointer; 12598 dcl temp fixed binary (18); 12599 12600 temp = get_temp_node (); 12601 t = addr (rands (temp)); 12602 12603 t -> temporary.data_type = int_mode; 12604 t -> temporary.operand_type = temp_type; 12605 t -> temporary.size = 1; 12606 t -> temporary.output_by = op; 12607 t -> temporary.not_in_storage = "1"b; 12608 12609 return (temp); 12610 12611 end create_integer_temporary; 12612 12613 is_invariant_in: 12614 procedure (opnd, lp) reducible returns (bit (1) aligned); 12615 12616 dcl opnd fixed binary (18), /* Operand which might be invariant */ 12617 lp pointer; /* -> loop in which invariance is tested */ 12618 12619 dcl (o, p) pointer; 12620 12621 p = addr (rands (opnd)); 12622 12623 if p -> node.node_type = symbol_node 12624 then if p -> symbol.coordinate > 0 12625 then return (^substr (lp -> loop.set -> bits, p -> symbol.coordinate, 1)); 12626 else ; 12627 12628 else if p -> node.node_type = temporary_node 12629 then if lp -> loop.computed ^= null 12630 then do; 12631 o = addr (quad (p -> temporary.output_by)); 12632 if o -> operator.coordinate > 0 12633 then return (^substr (lp -> loop.computed -> obits, o -> operator.coordinate, 1)); 12634 end; 12635 else ; 12636 12637 else if p -> node.node_type = constant_node 12638 then return ("1"b); 12639 12640 return ("0"b); 12641 12642 end is_invariant_in; 12643 12644 process_loop_end_lists: 12645 procedure (); 12646 12647 /* Turns the loop_end lists of the various loops into operators and operands. */ 12648 12649 dcl (i, j) fixed binary; 12650 dcl (op, last_operator, next_statement) fixed binary (18); 12651 dcl (c, fu, last_c, o) pointer; 12652 12653 do i = 1 to n_loops - 1; 12654 fu = loop_vector (i) -> loop.last_unit; 12655 if fu -> flow_unit.n_in_loop_end > 0 12656 then do; 12657 next_statement = fixed (addr (quad (fu -> flow_unit.last_statement)) -> opt_statement.next, 18); 12658 last_operator = addr (quad (next_statement)) -> opt_statement.prev_operator; 12659 op = insert_operator_after (loop_end_op, (fu -> flow_unit.n_in_loop_end), last_operator); 12660 o = addr (quad (op)); 12661 12662 j = 0; 12663 do c = fu -> flow_unit.loop_end_chain repeat c -> lchain.next while (c ^= null); 12664 j = j + 1; 12665 last_c = c; 12666 o -> operator.operand (j) = c -> lchain.value; 12667 end; 12668 12669 last_c -> lchain.next = free (size (lchain)); 12670 free (size (lchain)) = fu -> flow_unit.loop_end_chain; 12671 fu -> flow_unit.loop_end_chain = null; 12672 fu -> flow_unit.n_in_loop_end = 0; 12673 end; 12674 end; 12675 12676 end process_loop_end_lists; 12677 27 1 /* BEGIN fort_opt_utilities.incl.pl1 */ 27 2 27 3 /* Created: December 18, 1979 by Richard A. Barnes for register optimizer. */ 27 4 27 5 get_opt_space: proc(nwords) returns(ptr); 27 6 27 7 dcl nwords fixed bin(18); /* size of allocation */ 27 8 27 9 dcl p ptr; 27 10 27 11 /* allocates all space for fort_optimizer */ 27 12 27 13 retry: 27 14 p = addr(opt(next_free_opt)); 27 15 27 16 next_free_opt = next_free_opt + nwords; 27 17 27 18 if next_free_opt < opt_max_len 27 19 then return(p); 27 20 27 21 else do; 27 22 opt_base = get_next_temp_segment(shared_globals.opt_base,next_free_opt); 27 23 go to retry; 27 24 end; 27 25 27 26 end /* get_opt_space */; 27 27 27 28 create_chain: proc() returns(ptr); 27 29 27 30 dcl p ptr; 27 31 27 32 /* allocates chain nodes */ 27 33 27 34 if free(size(chain)) = null 27 35 then return(get_opt_space(size(chain))); 27 36 else do; 27 37 p = free(size(chain)); 27 38 free(size(chain)) = free(size(chain)) -> chain.next; 27 39 return(p); 27 40 end; 27 41 27 42 end /* create_chain */; 27 43 27 44 get_quad_space: proc(amt) returns(fixed bin(18)); 27 45 27 46 dcl amt fixed bin(18); /* amount to allocate */ 27 47 27 48 dcl place fixed bin(18); 27 49 27 50 place = next_free_quad; 27 51 next_free_quad = next_free_quad + amt; 27 52 if next_free_quad >= quad_max_len 27 53 then do; 27 54 call print_message(414,"The quadruple region",ltrim(char(quad_max_len))); 27 55 return(0); 27 56 end; 27 57 27 58 return(place); 27 59 27 60 end /* get_quad_space */; 27 61 27 62 chain_input: proc(p,o,i); 27 63 27 64 /* adds o to p's input list */ 27 65 27 66 dcl p ptr, /* ptr to temporary or array_ref that is input */ 27 67 o ptr, /* ptr to operator that p is input to */ 27 68 i fixed bin(18); /* which operand */ 27 69 27 70 dcl qoff fixed bin(18); 27 71 dcl (q,last) ptr; 27 72 27 73 q = create_input_to(); 27 74 27 75 q -> input_to.next = null; 27 76 q -> input_to.operator = o; 27 77 q -> input_to.which = i; 27 78 qoff = fixed(rel(q),18); 27 79 if p -> temporary.end_input_to = 0 27 80 then p -> temporary.start_input_to = qoff; 27 81 else do; 27 82 last = addr(polish(p -> temporary.end_input_to)); 27 83 last -> input_to.next = q; 27 84 end; 27 85 p -> temporary.end_input_to = qoff; 27 86 27 87 end /* chain_input */; 27 88 27 89 27 90 create_input_to: proc() returns(ptr); 27 91 27 92 dcl q ptr; 27 93 27 94 if freei = null 27 95 then q = get_polish_space(size(input_to)); 27 96 else do; 27 97 q = freei; 27 98 freei = freei -> input_to.next; 27 99 end; 27 100 27 101 return(q); 27 102 27 103 end /* create_input_to */; 27 104 27 105 27 106 get_polish_space: proc(nwords) returns(ptr); 27 107 27 108 dcl nwords fixed bin(18); /* size of allocation */ 27 109 27 110 dcl p ptr; 27 111 27 112 /* allocates polish space for input_to nodes */ 27 113 27 114 p = addr(polish(next_free_polish)); 27 115 27 116 next_free_polish = next_free_polish + nwords; 27 117 27 118 if next_free_polish < polish_max_len 27 119 then return(p); 27 120 27 121 else do; 27 122 call print_message(414,"The polish region",ltrim(char(polish_max_len))); 27 123 return(null); 27 124 end; 27 125 27 126 end /* get_polish_space */; 27 127 27 128 /* derives insert_* fields in back target */ 27 129 27 130 derive_insert_for_bt: proc(bt); 27 131 27 132 dcl bt ptr; /* -> back target */ 27 133 27 134 dcl (bt_statement, next_statement) fixed bin(18); 27 135 dcl (o, btst) ptr; 27 136 27 137 bt_statement = bt -> flow_unit.last_statement; 27 138 btst = addr(quad(bt_statement)); 27 139 o = addr(quad(btst -> opt_statement.first_operator)); 27 140 27 141 if o -> operator.op_code = jump_op 27 142 then do; 27 143 bt -> flow_unit.insert_statement = fixed(btst -> opt_statement.back, 18); 27 144 bt -> flow_unit.insert_operator = btst -> opt_statement.prev_operator; 27 145 end; 27 146 else do; 27 147 bt -> flow_unit.insert_statement = bt_statement; 27 148 next_statement = fixed(btst -> opt_statement.next, 18); 27 149 bt -> flow_unit.insert_operator = addr(quad(next_statement)) -> opt_statement.prev_operator; 27 150 end; 27 151 27 152 end /* derive_insert_for_bt */; 27 153 27 154 /* unthreads operator nodes. The operator to be unthreaded must not be the first or last operator in a chain. */ 27 155 27 156 unthread: proc(o); 27 157 27 158 dcl (o,nextp,backp) ptr; 27 159 27 160 dcl nullx fixed bin(18) int static options(constant) init(262142); 27 161 27 162 if o -> operator.next = nullx /* if already unthreaded, don't bother. */ 27 163 then return; 27 164 27 165 nextp = addr(quad(o -> operator.next)); 27 166 backp = addr(quad(o -> operator.back)); 27 167 nextp -> operator.back = o -> operator.back; 27 168 backp -> operator.next = o -> operator.next; 27 169 27 170 /* Make sure nobody uses the threading words again. An invalid use will cause a fault. */ 27 171 27 172 o -> operator.next, 27 173 o -> operator.back = nullx; 27 174 27 175 end /* unthread */ ; 27 176 27 177 put_in_loop_end: proc(pt,lp); 27 178 27 179 dcl (p, pt) ptr, /* -> temp to be put in loop end chain */ 27 180 lp ptr; /* -> loop in whose chain temp is to be inserted */ 27 181 27 182 dcl fu_to_put ptr; /* -> flow_unit in whose chain temp is to be inserted */ 27 183 27 184 dcl c ptr; 27 185 27 186 p = pt; 27 187 fu_to_put = lp -> loop.last_unit; 27 188 27 189 /* add to loop end chain */ 27 190 27 191 c = create_chain(); 27 192 c -> lchain.next = fu_to_put -> flow_unit.loop_end_chain; 27 193 c -> lchain.value = fixed(rel(p),18); 27 194 fu_to_put -> flow_unit.loop_end_chain = c; 27 195 fu_to_put -> flow_unit.n_in_loop_end = fu_to_put -> flow_unit.n_in_loop_end + 1; 27 196 27 197 /* increment the reference count */ 27 198 27 199 p -> temporary.ref_count = p -> temporary.ref_count + 1; 27 200 27 201 /* add an input item for this operand */ 27 202 27 203 call chain_input(p,c,-1); 27 204 27 205 p -> temporary.loop_end_fu_pos = fu_to_put -> flow_unit.position; 27 206 27 207 end /* put_in_loop_end */; 27 208 27 209 connect_expression: proc(opnd,op,p_which); 27 210 27 211 dcl opnd fixed bin(18), /* operand to be connectged to op */ 27 212 op fixed bin(18), /* operator to which opnd becomes an operand */ 27 213 (p_which,which) fixed bin(18); /* operand number that opnd becomes */ 27 214 27 215 27 216 dcl (o, p) ptr; 27 217 27 218 which = p_which; 27 219 27 220 o = addr(quad(op)); 27 221 o -> operator.operand(which) = opnd; 27 222 p = addr(rands(opnd)); 27 223 27 224 if p -> node.node_type = array_ref_node 27 225 | p -> node.node_type = temporary_node 27 226 then do; 27 227 p -> temporary.ref_count = p -> temporary.ref_count + 1; 27 228 p -> temporary.ref_count_copy = p -> temporary.ref_count_copy + 1; 27 229 call chain_input(p,o,which); 27 230 end; 27 231 27 232 end /* connect_expression */; 27 233 27 234 27 235 27 236 disconnect_temporary: proc(pt,p_o); 27 237 27 238 dcl (p,pt) ptr, /* ptr to temp being disconnected */ 27 239 (o,p_o) ptr; /* ptr to operator from which p is disconnected */ 27 240 27 241 dcl (inp,last) ptr; 27 242 dcl found bit(1) aligned; 27 243 27 244 p = pt; 27 245 o = p_o; 27 246 27 247 last = null; 27 248 found = "0"b; 27 249 inp = addr(polish(p -> temporary.start_input_to)); 27 250 27 251 do while(^ found & inp ^= null); 27 252 if inp -> input_to.operator = o 27 253 then found = "1"b; 27 254 else do; 27 255 last = inp; 27 256 inp = inp -> input_to.next; 27 257 end; 27 258 end; 27 259 27 260 if ^ found 27 261 then do; 27 262 call print_message(386); 27 263 return; 27 264 end; 27 265 27 266 if last ^= null 27 267 then do; 27 268 last -> input_to.next = inp -> input_to.next; 27 269 if inp -> input_to.next = null 27 270 then p -> temporary.end_input_to = fixed(rel(last),18); 27 271 end; 27 272 27 273 else if inp -> input_to.next = null 27 274 then p -> temporary.start_input_to, p -> temporary.end_input_to = 0; 27 275 else p -> temporary.start_input_to = fixed(rel(inp -> input_to.next),18); 27 276 27 277 p -> temporary.ref_count = p -> temporary.ref_count - 1; 27 278 p -> temporary.ref_count_copy = p -> temporary.ref_count_copy - 1; 27 279 27 280 end /* disconnect_temporary */; 27 281 27 282 in_namelist: proc(o,variable) returns(bit(1) aligned); 27 283 27 284 dcl o ptr, /* -> to {read|write}_namelist operator */ 27 285 variable fixed bin(18); /* variable being searched for */ 27 286 27 287 dcl (var,i,ipol) fixed bin(18); 27 288 27 289 var = variable; 27 290 ipol = addr(rands(o -> operator.operand(1))) -> symbol.initial; 27 291 27 292 do i = 1 to polish(ipol); 27 293 if polish(ipol+i) = variable 27 294 then return("1"b); 27 295 end; 27 296 27 297 return("0"b); 27 298 27 299 end /* in_namelist */; 27 300 27 301 /* END fort_opt_utilities.incl.pl1 */ 12678 12679 12680 /**** FLD BUILTIN CODE ****/ 12681 signal_error: 12682 procedure (); 12683 12684 /* Aborts from an FLD builtin error */ 12685 12686 imac = fixed (rel (addr (fort_opt_macros_$abort_list)), 18); 12687 go to loop; 12688 12689 end signal_error; 12690 12691 one_word_dt: 12692 procedure (opnd) returns (bit (1)); 12693 12694 /* Returns true if "opnd" has a data type that takes up exactly one word 12695* of aligned storage. */ 12696 12697 dcl opnd fixed bin (18); 12698 dcl p pointer; 12699 12700 p = addr (rands (opnd)); 12701 if (p -> node.data_type = int_mode) | (p -> node.data_type = real_mode) | (p -> node.data_type = typeless_mode) 12702 then return ("1"b); 12703 else if (p -> node.data_type = char_mode) 12704 then if (p -> node.node_type = symbol_node) 12705 then return (p -> symbol.char_size = 3 & ^p -> symbol.aliasable); 12706 else if (p -> node.node_type = char_constant_node) 12707 then return (p -> char_constant.length = 4); 12708 else return ("0"b); 12709 else return ("0"b); 12710 end one_word_dt; 12711 12712 generate_mask: 12713 procedure (start, len) returns (fixed bin (18)); 12714 12715 /* Creates an integer constant mask */ 12716 12717 dcl (start, len) fixed bin (18); 12718 dcl mask fixed bin (35); 12719 12720 mask = 0; 12721 substr (unspec (mask), start + 1, len) = "111111111111111111111111111111111111"b; 12722 12723 return (create_integer_constant (mask)); 12724 end generate_mask; 12725 12726 rhs_fld: 12727 procedure; 12728 12729 /* emits the code for the case of the fld intrinsic on the right hand 12730* side of an assignement statement. The code is emitted manually as the macros are 12731* are not general enough to allow computed bit masks. */ 12732 12733 dcl shift fixed bin; 12734 dcl (arg1, arg2, arg3, start, len) fixed bin (18); 12735 dcl (found_error, arg1_is_const, arg2_is_const) bit (1) init ("0"b); 12736 12737 arg1 = stack (get_operand (5)); 12738 if addr (rands (arg1)) -> node.data_type ^= int_mode 12739 then do; 12740 call print_message (359, arg1); 12741 found_error = "1"b; 12742 end; 12743 arg2 = stack (get_operand (6)); 12744 if addr (rands (arg2)) -> node.data_type ^= int_mode 12745 then do; 12746 call print_message (359, arg2); 12747 found_error = "1"b; 12748 end; 12749 arg3 = stack (get_operand (7)); 12750 if ^one_word_dt (arg3) 12751 then do; 12752 call print_message (360, arg3); 12753 found_error = "1"b; 12754 end; 12755 if found_error 12756 then call signal_error; 12757 12758 if addr (rands (arg2)) -> node.node_type = constant_node 12759 then do; 12760 arg2_is_const = "1"b; 12761 len = addr (addr (rands (arg2)) -> constant.value) -> based_integer; 12762 if len < 1 | len > 36 12763 then call print_message (364); 12764 if len = 0 12765 then do; 12766 call load (create_integer_constant (0), in_tq); 12767 return; 12768 end; 12769 end; 12770 if addr (rands (arg1)) -> node.node_type = constant_node 12771 then do; 12772 arg1_is_const = "1"b; 12773 start = addr (addr (rands (arg1)) -> constant.value) -> based_integer; 12774 if start < 0 | start > 35 12775 then call print_message (363); 12776 end; 12777 12778 if arg1_is_const & arg2_is_const 12779 then do; 12780 start = min (max (start, 0), 35); 12781 len = min (max (len, 0), 36 - start); 12782 shift = 36 - (start + len); 12783 12784 call load (arg3, in_tq); 12785 12786 if start = 0 12787 then do; 12788 if len = 36 12789 then return; 12790 call emit_single (qrl, shift - bias); 12791 end; 12792 12793 else if shift = 0 12794 then call emit_single (anq, generate_mask (start, len)); 12795 12796 else do; 12797 call emit_single (qls, start - bias); 12798 call emit_single (qrl, (36 - len) - bias); 12799 end; 12800 call reset_eaq (Q); 12801 return; 12802 end; 12803 else do; 12804 call load (arg3, in_tq); 12805 12806 if arg1_is_const 12807 then do; 12808 if start ^= 0 12809 then call emit_single (qls, start - bias); 12810 call emit_single (lca, arg2); 12811 call emit_with_tag (qrl, 36, AL_mod); 12812 call reset_eaq (A); 12813 end; 12814 else if arg2_is_const 12815 then do; 12816 call load (arg1, in_ia); 12817 call emit_with_tag (qls, 0, AL_mod); 12818 call emit_single (qrl, (36 - len) - bias); 12819 end; 12820 else do; 12821 call load (arg1, in_ia); 12822 call emit_with_tag (qls, 0, AL_mod); 12823 call emit_single (lca, arg2); 12824 call emit_with_tag (qrl, 36, AL_mod); 12825 call reset_eaq (A); 12826 end; 12827 call reset_eaq (Q); 12828 return; 12829 end; 12830 return; 12831 end rhs_fld; 12832 12833 lhs_fld: 12834 procedure; 12835 12836 /* emits the code for the case of the fld intrinsic on the left hand side 12837* of an assignment statement. The code is emitted manually as the macros 12838* are not general enough to allow certain optimizations (such as bit 12839* masks. */ 12840 12841 dcl shift fixed bin; 12842 dcl RHS fixed bin (35); 12843 dcl (arg1, arg2, arg3, arg4, start, len) fixed bin (18); 12844 dcl (found_error, arg1_is_const, arg2_is_const) bit (1) init ("0"b); 12845 dcl copy builtin; 12846 12847 arg1 = stack (get_operand (1)); 12848 if addr (rands (arg1)) -> node.data_type ^= int_mode 12849 then do; 12850 call print_message (359, arg1); 12851 found_error = "1"b; 12852 end; 12853 arg2 = stack (get_operand (2)); 12854 if addr (rands (arg2)) -> node.data_type ^= int_mode 12855 then do; 12856 call print_message (359, arg2); 12857 found_error = "1"b; 12858 end; 12859 arg3 = stack (get_operand (3)); 12860 if ^one_word_dt (arg3) 12861 then do; 12862 call print_message (360, arg3); 12863 found_error = "1"b; 12864 end; 12865 arg4 = stack (get_operand (4)); 12866 if ^one_word_dt (arg4) 12867 then do; 12868 call print_message (361); 12869 found_error = "1"b; 12870 end; 12871 if found_error 12872 then call signal_error; 12873 12874 if addr (rands (arg2)) -> node.node_type = constant_node 12875 then do; 12876 arg2_is_const = "1"b; 12877 len = addr (addr (rands (arg2)) -> constant.value) -> based_integer; 12878 if len < 1 | len > 36 12879 then call print_message (364); 12880 if len = 0 12881 then return; 12882 end; 12883 if addr (rands (arg1)) -> node.node_type = constant_node 12884 then do; 12885 arg1_is_const = "1"b; 12886 start = addr (addr (rands (arg1)) -> constant.value) -> based_integer; 12887 if start < 0 | start > 35 12888 then call print_message (363); 12889 end; 12890 12891 if arg1_is_const & arg2_is_const 12892 then do; 12893 start = min (max (start, 0), 35); 12894 len = min (max (len, 0), 36 - start); 12895 12896 if start = 0 & len = 36 12897 then do; 12898 call load (arg4, in_tq); 12899 call store (arg3, in_tq, 0); 12900 return; 12901 end; 12902 12903 if addr (rands (arg4)) -> node.node_type = constant_node 12904 then do; 12905 unspec (RHS) = 12906 copy ("0"b, start) || substr (addr (rands (arg4)) -> constant.value, 36 - len + 1, len); 12907 call load (create_integer_constant (RHS), in_tq); 12908 end; 12909 else do; 12910 call load (arg4, in_tq); 12911 shift = 36 - start - len; 12912 if shift > 0 12913 then call emit_single (qls, shift - bias); 12914 end; 12915 12916 /* increment the count as it is automatically decremented by emit_single */ 12917 call drop_count (arg3, -1); 12918 call emit_single (erq, arg3); 12919 call emit_single (anq, generate_mask (start, len)); 12920 call emit_single (ersq, arg3); 12921 call reset_eaq (Q); 12922 end; 12923 12924 else if arg1_is_const 12925 then do; 12926 call use_eaq (0, EAQ, 0); 12927 call reserve_regs (("1"b)); 12928 12929 call emit_single (lxl0, arg2); 12930 12931 /* increment the count as it is automatically decremented by emit_single */ 12932 call drop_count (arg3, -1); 12933 call emit_single (load_inst (in_ia), arg3); 12934 call emit_with_tag (alr, start, X0_mod); 12935 call emit_single (era, arg4); 12936 call emit_with_tag (load_inst (in_iq), 0, DL_mod); 12937 call emit_with_tag (lrs, 0, X0_mod); 12938 if start ^= 0 12939 then call emit_single (qrl, start - bias); 12940 call emit_single (ersq, arg3); 12941 end; 12942 12943 else if arg2_is_const 12944 then do; 12945 call use_eaq (0, EAQ, 0); 12946 call reserve_regs (("1"b)); 12947 12948 call emit_single (lxl0, arg1); 12949 12950 /* increment the count as it is automatically decremented by emit_single */ 12951 call drop_count (arg3, -1); 12952 call emit_single (load_inst (in_ia), arg3); 12953 call emit_with_tag (alr, len, X0_mod); 12954 call emit_single (era, arg4); 12955 call emit_with_tag (load_inst (in_iq), 0, DL_mod); 12956 call emit_single (lrs, len - bias); 12957 call emit_with_tag (qrl, 0, X0_mod); 12958 call emit_single (ersq, arg3); 12959 end; 12960 12961 else do; 12962 call use_eaq (0, EAQ, 0); 12963 call reserve_regs (("11"b)); 12964 12965 call emit_single (lxl0, arg1); 12966 call emit_single (lxl1, arg2); 12967 12968 /* increment the count as it is automatically decremented by emit_single */ 12969 call drop_count (arg3, -1); 12970 call emit_single (load_inst (in_ia), arg3); 12971 call emit_with_tag (alr, 0, X0_mod); 12972 call emit_with_tag (alr, 0, X1_mod); 12973 call emit_single (era, arg4); 12974 call emit_with_tag (load_inst (in_iq), 0, DL_mod); 12975 call emit_with_tag (lrs, 0, X1_mod); 12976 call emit_with_tag (qrl, 0, X0_mod); 12977 call emit_single (ersq, arg3); 12978 end; 12979 return; 12980 end lhs_fld; 12981 12982 start_subprogram: 12983 procedure (); 12984 12985 /* Initializes global variables for a subprogram. Most references 12986* are nonlocal. */ 12987 12988 dcl i fixed binary; 12989 dcl (last, temp) fixed binary (18); 12990 12991 cur_lp, fu, lp_msp = null; 12992 12993 cs = addr (rands (cur_subprogram)); 12994 call get_subr_options (cs); 12995 12996 loop_vector_p = cs -> subprogram.loop_vector_p; 12997 n_loops = cs -> subprogram.n_loops; 12998 max_sym = cs -> subprogram.max_sym; 12999 max_operators = cs -> subprogram.max_operators; 13000 13001 if analyzing 13002 then do; 13003 do i_loop = 1 to n_loops - 1 while (loop_vector (i_loop) -> loop.members = null); 13004 end; 13005 13006 if i_loop >= n_loops 13007 then iquad = cs -> subprogram.last_quad; 13008 13009 else do; 13010 iquad = loop_vector (i_loop) -> loop.members -> flow_unit.first_statement; 13011 13012 /* refresh flow_unit.insert_operator for all back targets */ 13013 13014 do i = 1 to n_loops - 1; 13015 if loop_vector (i) -> loop.members ^= null 13016 then call derive_insert_for_bt ((loop_vector (i) -> loop.back_target)); 13017 end; 13018 end; 13019 end; 13020 13021 else iquad = cs -> subprogram.first_quad; 13022 13023 if cs -> subprogram.subprogram_type ^= main_program 13024 then do; 13025 last_auto_loc = last_auto_loc + mod (last_auto_loc, 2); 13026 cs -> subprogram.entry_info = last_auto_loc; 13027 call set_address_offset (addr (rands (builtins (8))), last_auto_loc, entry_info_size, word_units); 13028 last_auto_loc = last_auto_loc + entry_info_size; 13029 13030 if last_auto_loc > max_stack_size 13031 then call print_message (414, 13032 "making subroutine entry for " || addr (rands (cs -> subprogram.symbol)) -> symbol.name 13033 || " has exceeded the stack frame", max_stack_size - bias); 13034 end; 13035 13036 do i = 1 to 3; 13037 if free_temps (i) ^= 0 13038 then do; 13039 do temp = free_temps (i) repeat addr (rands (temp)) -> temporary.next while (temp ^= 0); 13040 last = temp; 13041 end; 13042 13043 addr (rands (last)) -> temporary.next = next_free_temp; 13044 next_free_temp = free_temps (i); 13045 free_temps (i) = 0; 13046 end; 13047 end; 13048 end start_subprogram; 13049 13050 reset_subprogram: 13051 procedure (); 13052 13053 /* This resets the address, not_in_storage, and value_in fields of all 13054* temps produced in all loops, and it resets statement nodes 13055* throughout the program. */ 13056 13057 dcl (lp, fu, stm, o, outp) pointer; 13058 dcl (next_unit_statement, next_statement, op) fixed binary (18); 13059 dcl i fixed binary; 13060 13061 call discard_state; 13062 state_discarded = "0"b; /* To make merge_state CHEAP! */ 13063 13064 do i = 1 to n_loops; 13065 lp = loop_vector (i); 13066 13067 do fu = lp -> loop.members repeat fu -> flow_unit.next_in_loop while (fu ^= null); 13068 if fu -> flow_unit.next ^= null 13069 then next_unit_statement = fu -> flow_unit.next -> flow_unit.first_statement; 13070 else next_unit_statement = 0; 13071 13072 if fu -> flow_unit.first_statement ^= 0 13073 then do cur_statement = fu -> flow_unit.first_statement repeat next_statement 13074 while (cur_statement ^= next_unit_statement); 13075 stm = addr (quad (cur_statement)); 13076 next_statement = fixed (stm -> opt_statement.next, 18); 13077 13078 if stm -> opt_statement.machine_state ^= 0 13079 then call free_machine_state (stm); 13080 13081 do op = stm -> opt_statement.first_operator repeat o -> operator.next 13082 while (op ^= next_statement); 13083 o = addr (quad (op)); 13084 if o -> operator.output > 0 13085 then do; 13086 outp = addr (rands (o -> operator.output)); 13087 if outp -> node.node_type = temporary_node 13088 then do; 13089 unspec (outp -> temporary.address) = "0"b; 13090 outp -> temporary.not_in_storage = "1"b; 13091 outp -> temporary.ref_count_copy = 0; 13092 end; 13093 end; 13094 end; 13095 end; 13096 end; 13097 end; 13098 13099 state_discarded = "1"b; 13100 13101 return; 13102 13103 free_machine_state: 13104 procedure (stm); 13105 13106 dcl stm pointer; 13107 13108 call merge_state (current_ms, addr (rands (stm -> opt_statement.machine_state)) -> machine_state, "1"b); 13109 stm -> opt_statement.machine_state = 0; 13110 13111 end free_machine_state; 13112 13113 end reset_subprogram; 13114 13115 end interpreter; 13116 13117 get_char_size: 13118 procedure (pt) returns (fixed binary (18)); 13119 13120 /* Procedure to return the size of a character string. 13121* The size is returned as a count (if it is constant) 13122* or as an operand index. */ 13123 13124 dcl (p, pt) pointer; /* Pointer to character node */ 13125 13126 p = pt; 13127 13128 if p -> node.data_type ^= char_mode 13129 then call print_message (412, fixed (rel (p), 18)); 13130 13131 if p -> node.node_type = char_constant_node 13132 then return (p -> char_constant.length - bias); 13133 13134 if p -> node.node_type = symbol_node 13135 then do; 13136 if p -> symbol.v_length ^= 0 13137 then return (p -> symbol.v_length); 13138 else return (p -> symbol.char_size + 1 - bias); 13139 end; 13140 13141 if p -> node.node_type = array_ref_node 13142 then do; 13143 if p -> array_ref.variable_length 13144 then return (p -> array_ref.length); 13145 else return (p -> array_ref.length - bias); 13146 end; 13147 13148 if p -> node.node_type = temporary_node 13149 then do; 13150 if p -> temporary.variable_length 13151 then return (p -> temporary.length); 13152 else return (p -> temporary.length - bias); 13153 end; 13154 13155 call print_message (412, fixed (rel (p), 18)); 13156 13157 end get_char_size; 13158 13159 make_symbol_descriptor: 13160 procedure (var) returns (fixed binary (18)); 13161 13162 /* Builds a descriptor for the symbol var. If var is a parameter 13163* of star or expression extents, the appropriate fields of the 13164* descriptor are filled in later by get_param_array_size or 13165* get_param_char_size. */ 13166 13167 dcl var fixed binary (18); /* symbol that needs a descriptor */ 13168 13169 dcl (p, d, cs) pointer; 13170 dcl (i, cm, desc, dt, const, ndims, char_star_ndims, csize) fixed binary (18); 13171 dcl v_length bit (1) aligned; 13172 13173 dcl 1 descriptor aligned, 13174 2 type_word aligned, 13175 3 bit_type unaligned, 13176 4 flag bit (1) unaligned, 13177 4 type bit (6) unaligned, 13178 4 packed bit (1) unaligned, 13179 3 number_dims fixed binary (3) unaligned, 13180 3 size fixed binary (23) unaligned, 13181 2 array_info (7) aligned, 13182 3 l_bound fixed binary (18), 13183 3 h_bound fixed binary (18), 13184 3 multiplier fixed binary (18); 13185 13186 dcl desc_image char (chars_per_word * (1 + char_star_ndims + 3 * ndims)) unaligned based (addr (descriptor)); 13187 13188 dcl (length, size) builtin; 13189 13190 p = addr (rands (var)); 13191 unspec (descriptor) = "0"b; 13192 v_length = "0"b; 13193 ndims, char_star_ndims = 0; 13194 13195 /* If the symbol already has a descriptor, return it */ 13196 13197 if p -> symbol.hash_chain ^= 0 13198 then return (p -> symbol.hash_chain); 13199 13200 /* Initialize the descriptor's type word */ 13201 13202 if p -> symbol.operand_type >= bif 13203 then unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, 7)); 13204 else do; 13205 dt = p -> symbol.data_type; 13206 unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, dt)); 13207 if dt = char_mode 13208 then do; 13209 if p -> symbol.units = char_units 13210 then descriptor.packed = "1"b; 13211 csize = get_char_size (p); 13212 if csize < 0 13213 then descriptor.size = csize + bias; 13214 else do; 13215 v_length = "1"b; 13216 unspec (descriptor.size) = "77777777"b3; 13217 end; 13218 end; 13219 end; 13220 13221 /* If symbol is dimensioned, add the dimension info */ 13222 13223 /* If we would have to concoct runtime character*(*) length for a 13224* funtime symbol table, reserve space for the character multipliers. */ 13225 13226 if p -> symbol.dimensioned 13227 then do; 13228 d = addr (rands (p -> symbol.dimension)); 13229 ndims = d -> dimension.number_of_dims; 13230 descriptor.number_dims = ndims; 13231 13232 if v_length & shared_globals.user_options.table 13233 then char_star_ndims = ndims; /* count char*(*) multiplier extras */ 13234 13235 if descriptor.packed 13236 then cm = get_size_in_bits ((p -> symbol.element_size), (p -> symbol.units)); 13237 else cm = get_size_in_words ((p -> symbol.element_size), (p -> symbol.units)); 13238 13239 do i = 1 to ndims; 13240 13241 if ^v_length 13242 then descriptor.multiplier (i) = cm; 13243 13244 if string (d -> dimension.v_bound (i)) = "00"b 13245 then do; 13246 descriptor.l_bound (i) = d -> dimension.lower_bound (i); 13247 descriptor.h_bound (i) = d -> dimension.upper_bound (i); 13248 if ^v_length 13249 then cm = cm * d -> dimension.size (i); 13250 end; 13251 else do; 13252 v_length = "1"b; 13253 13254 /* if no specific bounds are seen, fill in '*' bounds in the static descriptor. 13255* This requires variable descriptor math to over-write the bounds in auto 13256* when called. */ 13257 13258 if ^d -> dimension.v_bound (i).lower 13259 then descriptor.l_bound (i) = d -> dimension.lower_bound (i); 13260 else unspec (descriptor.l_bound (i)) = "400000000000"b3; 13261 /* '*' bound */ 13262 13263 if ^d -> dimension.v_bound (i).upper 13264 then descriptor.h_bound (i) = d -> dimension.upper_bound (i); 13265 else if (i = ndims) & d -> dimension.assumed_size 13266 then unspec (descriptor.h_bound (i)) = "377777777777"b3; 13267 else unspec (descriptor.h_bound (i)) = "400000000000"b3; 13268 /* '*' bound */ 13269 end; 13270 end; 13271 end; 13272 13273 /* Create a constant node for the descriptor */ 13274 13275 if ndims = 0 13276 then const = create_constant (int_mode, unspec (descriptor.type_word)); 13277 else const = create_char_constant (desc_image); 13278 13279 /* If the descriptor must be filled in at runtime, allocate a 13280* symbol node for it. */ 13281 13282 if v_length 13283 then do; 13284 desc = create_node (symbol_node, size (symbol)); 13285 d = addr (rands (desc)); 13286 d -> symbol.data_type = char_mode; 13287 d -> symbol.by_compiler = "1"b; 13288 d -> symbol.character = "1"b; 13289 d -> symbol.allocate = "1"b; 13290 d -> symbol.automatic = "1"b; 13291 d -> symbol.char_size = length (desc_image) - 1; 13292 d -> symbol.element_size = 1 + char_star_ndims + 3 * ndims; 13293 d -> symbol.general = const; 13294 13295 /* Thread in the new symbol, so its storage is allocated */ 13296 13297 cs = addr (rands (cur_subprogram)); 13298 addr (rands (cs -> subprogram.last_symbol)) -> node.next = desc; 13299 cs -> subprogram.last_symbol = desc; 13300 end; 13301 else desc = const; 13302 13303 /* Remember that we made this descriptor */ 13304 13305 p -> symbol.hash_chain = desc; 13306 13307 /* Return the descriptor node */ 13308 13309 return (desc); 13310 13311 end make_symbol_descriptor; 13312 13313 make_entry_descriptor: 13314 procedure (var) returns (fixed binary (18)); 13315 13316 dcl var fixed binary (18); /* Symbol that needs a descriptor */ 13317 13318 dcl (p, d) pointer; 13319 dcl (i, cm, dt, const, ndims, char_star_ndims, csize) fixed binary (18); 13320 dcl v_length bit (1) aligned; 13321 13322 dcl 1 descriptor aligned, 13323 2 type_word aligned, 13324 3 bit_type unaligned, 13325 4 flag bit (1) unaligned, 13326 4 type bit (6) unaligned, 13327 4 packed bit (1) unaligned, 13328 3 number_dims fixed binary (3) unaligned, 13329 3 size fixed binary (23) unaligned, 13330 2 array_info (7) aligned, 13331 3 l_bound fixed binary (18), 13332 3 h_bound fixed binary (18), 13333 3 multiplier fixed binary (18); 13334 13335 dcl desc_image character (chars_per_word * (1 + char_star_ndims + 3 * ndims)) unaligned based (addr (descriptor)); 13336 13337 13338 p = addr (rands (var)); 13339 unspec (descriptor) = "0"b; 13340 v_length = "0"b; 13341 ndims, char_star_ndims = 0; 13342 13343 /* If the symbol already has a descriptor, return it. */ 13344 13345 if p -> symbol.hash_chain ^= 0 13346 then do; 13347 d = addr (rands (p -> symbol.hash_chain)); 13348 13349 /* return only constant nodes */ 13350 if d -> node.node_type = symbol_node 13351 then d = addr (rands (d -> symbol.general)); 13352 13353 /* make sure the constant is allocated */ 13354 d -> node.allocate = "1"b; 13355 return (fixed (rel (d), 18)); 13356 end; 13357 13358 /* Initialize the descriptor's type word */ 13359 13360 if p -> symbol.operand_type >= bif 13361 then unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, 7)); 13362 else do; 13363 dt = p -> symbol.data_type; 13364 unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, dt)); 13365 if dt = char_mode 13366 then do; 13367 if p -> symbol.units = char_units 13368 then descriptor.packed = "1"b; 13369 csize = get_char_size (p); 13370 if csize < 0 13371 then descriptor.size = csize + bias; 13372 else do; 13373 v_length = "1"b; 13374 unspec (descriptor.size) = "77777777"b3; 13375 end; 13376 end; 13377 end; 13378 13379 /* If symbol is dimensioned, add the dimension info */ 13380 /* If we would have to concoct runtime character*(*) lengths for a 13381* runtime symbol table, reserve space for the character multipliers. */ 13382 13383 if p -> symbol.dimensioned 13384 then do; 13385 d = addr (rands (p -> symbol.dimension)); 13386 ndims = d -> dimension.number_of_dims; 13387 descriptor.number_dims = ndims; 13388 13389 if v_length & shared_globals.user_options.table 13390 then char_star_ndims = ndims; /* count char*(*) multiplier extras */ 13391 13392 if descriptor.packed 13393 then cm = get_size_in_bits ((p -> symbol.element_size), (p -> symbol.units)); 13394 else cm = get_size_in_words ((p -> symbol.element_size), (p -> symbol.units)); 13395 13396 do i = 1 to ndims; 13397 13398 if ^v_length 13399 then descriptor.multiplier (i) = cm; 13400 13401 if string (d -> dimension.v_bound (i)) = "00"b 13402 then do; 13403 descriptor.l_bound (i) = d -> dimension.lower_bound (i); 13404 descriptor.h_bound (i) = d -> dimension.upper_bound (i); 13405 if ^v_length 13406 then cm = cm * d -> dimension.size (i); 13407 end; 13408 else do; 13409 v_length = "1"b; 13410 13411 /* if no specific bounds are seen, fill in '*' bounds in the static descriptor. 13412* This requires variable descriptor math to over-write the bounds in auto 13413* when called. */ 13414 13415 if ^d -> dimension.v_bound (i).lower 13416 then descriptor.l_bound (i) = d -> dimension.lower_bound (i); 13417 else unspec (descriptor.l_bound (i)) = "400000000000"b3; 13418 /* '*' bound */ 13419 13420 if ^d -> dimension.v_bound (i).upper 13421 then descriptor.h_bound (i) = d -> dimension.upper_bound (i); 13422 else if (i = ndims) & d -> dimension.assumed_size 13423 then unspec (descriptor.h_bound (i)) = "377777777777"b3; 13424 else unspec (descriptor.h_bound (i)) = "400000000000"b3; 13425 /* '*' bound */ 13426 end; 13427 end; 13428 end; 13429 13430 /* Create a constant node for the descriptor */ 13431 13432 if ndims = 0 13433 then const = create_constant (int_mode, unspec (descriptor.type_word)); 13434 else const = create_char_constant (desc_image); 13435 13436 /* Remember that we made this descriptor */ 13437 13438 p -> symbol.hash_chain = const; 13439 13440 /* Make sure the constant is allocated. */ 13441 13442 addr (rands (const)) -> node.allocate = "1"b; 13443 13444 /* Return the descriptor node */ 13445 13446 return (const); 13447 13448 end make_entry_descriptor; 13449 13450 /**** DATA INITIALIZATION ****/ 13451 13452 initialize_static: 13453 procedure (); 13454 13455 dcl (cur_subr, hdr) fixed binary (18); 13456 dcl (csp, h, s) pointer; 13457 13458 dcl base ptr; 13459 dcl full_pointer ptr based (base); 13460 dcl packed_pointer ptr unaligned based (base); 13461 13462 13463 do cur_subr = first_subprogram repeat csp -> subprogram.next_subprogram while (cur_subr > 0); 13464 csp = addr (rands (cur_subr)); 13465 13466 /* Do static Large Arrays - full null pointer. */ 13467 13468 do hdr = csp -> subprogram.storage_info.first (14) repeat h -> node.next while (hdr > 0); 13469 h = addr (rands (hdr)); 13470 base = addrel (link_base, h -> header.location); 13471 full_pointer = null (); 13472 end; 13473 13474 /* Do static Very Large Arrays - packed null pointer. */ 13475 13476 do hdr = csp -> subprogram.storage_info.first (16) repeat h -> node.next while (hdr > 0); 13477 h = addr (rands (hdr)); 13478 s = addr (rands (h -> header.VLA_base_addressor)); 13479 if ^s -> symbol.large_address 13480 then base = addrel (link_base, s -> symbol.address.offset); 13481 else base = addrel (link_base, s -> symbol.address.offset + s -> symbol.location); 13482 packed_pointer = null (); 13483 end; 13484 13485 /* Do Very Large Common - packed null pointer. */ 13486 13487 do hdr = csp -> subprogram.storage_info.first (17) repeat h -> node.next while (hdr > 0); 13488 h = addr (rands (hdr)); 13489 s = addr (rands (h -> header.VLA_base_addressor)); 13490 if ^s -> symbol.large_address 13491 then base = addrel (link_base, s -> symbol.address.offset); 13492 else base = addrel (link_base, s -> symbol.address.offset + s -> symbol.location); 13493 packed_pointer = null (); 13494 end; 13495 end; 13496 13497 13498 /* Initialize normal static. */ 13499 do cur_subr = first_subprogram repeat csp -> subprogram.next_subprogram while (cur_subr > 0); 13500 csp = addr (rands (cur_subr)); 13501 call initialize (link_base, 5); 13502 end; 13503 13504 /* initialize long_profile_header */ 13505 13506 if generate_profile & generate_long_profile 13507 then do; 13508 base = addrel (link_base, profile_start); 13509 unspec (base -> long_profile_header) = "0"b; 13510 end; 13511 return; 13512 13513 13514 initialize_auto: 13515 entry; 13516 13517 auto_template = text_pos; 13518 13519 do cur_subr = first_subprogram repeat csp -> subprogram.next_subprogram while (cur_subr > 0); 13520 csp = addr (rands (cur_subr)); 13521 call initialize (addrel (object_base, text_pos - first_auto_var_loc), 1); 13522 end; 13523 13524 text_pos = text_pos + (csp -> subprogram.next_loc (2) - first_auto_var_loc); 13525 13526 return; 13527 13528 initialize: 13529 procedure (pt, start); 13530 13531 dcl pt pointer, /* base of section to place initialized vars */ 13532 start fixed binary (18); /* first bucket to initialize */ 13533 13534 dcl (base, h, s) pointer; 13535 dcl (sym, hdr, i) fixed binary (18); 13536 13537 base = pt; 13538 13539 do i = start to start + 1; 13540 do hdr = csp -> subprogram.storage_info.first (i) repeat h -> node.next while (hdr > 0); 13541 h = addr (rands (hdr)); 13542 if h -> node.node_type = header_node 13543 then do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 13544 s = addr (rands (sym)); 13545 if s -> symbol.initialed 13546 then call initialize_symbol (s, base); 13547 end; 13548 else call initialize_symbol (h, base); 13549 end; 13550 end; 13551 13552 end initialize; 13553 13554 end initialize_static; 13555 13556 list_initialize: 13557 procedure (pt, hdr, words); 13558 13559 dcl pt pointer, /* Base of section to place initialized vars */ 13560 /* left at last point of init */ 13561 hdr fixed binary (18), /* header to init from */ 13562 words fixed bin (18); /* words used for init info + original value */ 13563 13564 dcl (h, s) pointer; 13565 dcl sym fixed binary (18); 13566 dcl start_offset fixed bin (18); 13567 dcl end_offset fixed bin (35); 13568 13569 h = addr (rands (hdr)); 13570 if ^h -> header.initialed 13571 then return; /* No work to do */ 13572 end_offset = 0; 13573 start_offset = fixed (rel (pt), 18); 13574 13575 do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 13576 s = addr (rands (sym)); 13577 13578 if s -> symbol.initialed 13579 then call list_initialize_symbol (s, pt, end_offset); 13580 end; 13581 pt -> create_init_entry.length = 0; /* END */ 13582 pt = addrel (pt, 1); 13583 13584 /* calculate words taken for initialization list data */ 13585 13586 words = words + fixed (rel (pt), 18) - start_offset; 13587 return; 13588 end list_initialize; 13589 13590 initialize_symbol: 13591 procedure (sym_pt, init_pt); 13592 13593 dcl (sym_pt, init_pt) pointer; 13594 13595 dcl (s, address) pointer; 13596 dcl (index, case, csize, limit, off) fixed binary (18); 13597 13598 dcl 1 initial aligned auto, 13599 2 next fixed binary (18), 13600 2 limit fixed binary (18), 13601 2 value fixed binary (18); 13602 13603 dcl 1 initial_in_polish aligned based, 13604 2 next fixed binary (18) aligned, 13605 2 limit fixed binary (18) aligned, 13606 2 value fixed binary (18) aligned; 13607 13608 dcl single_target (10000) bit (36) aligned based (address); 13609 13610 dcl double_target (10000) bit (72) aligned based (address); 13611 13612 dcl char_target (10000) char (csize) aligned based (address); 13613 13614 dcl char77_target (10000) char (csize) unaligned based (address); 13615 13616 dcl char_overlay (0:3) char (1) unaligned based; 13617 13618 s = sym_pt; 13619 address = init_pt; 13620 index = 1; 13621 13622 /* Develop a full pointer to the initial template for the symbol */ 13623 13624 off = s -> symbol.address.offset; 13625 if s -> symbol.large_address 13626 then off = off + s -> symbol.location; 13627 address = addrel (address, off); 13628 13629 if s -> symbol.units = char_units 13630 then do; 13631 off = s -> symbol.address.char_num; 13632 address = addr (address -> char_overlay (off)); 13633 end; 13634 13635 if s -> symbol.character 13636 then if s -> symbol.units = char_units 13637 then do; 13638 csize = s -> symbol.char_size + 1; 13639 case = 4; 13640 end; 13641 else do; 13642 csize = s -> symbol.char_size + 1; 13643 case = 3; 13644 end; 13645 else case = data_type_size (s -> symbol.data_type); 13646 13647 if ^s -> symbol.dimensioned 13648 then do; 13649 initial.value = addr (polish (s -> symbol.initial)) -> initial_in_polish.value; 13650 if initial.value ^= gap_value 13651 then call assign_value; 13652 return; 13653 end; 13654 13655 initial.next = s -> symbol.initial; 13656 limit = 0; 13657 13658 do while (initial.next > 0); 13659 13660 /* can't use aggregate assignment because of bug 1466 */ 13661 13662 initial.value = addr (polish (initial.next)) -> initial_in_polish.value; 13663 initial.limit = addr (polish (initial.next)) -> initial_in_polish.limit; 13664 initial.next = addr (polish (initial.next)) -> initial_in_polish.next; 13665 limit = limit + initial.limit; 13666 13667 do while (index <= limit); 13668 if initial.value ^= gap_value 13669 then call assign_value; 13670 index = index + 1; 13671 end; 13672 13673 end; 13674 13675 assign_value: 13676 procedure (); 13677 13678 go to action (case); 13679 13680 action (1): 13681 single_target (index) = addr (rands (initial.value)) -> constant.value; 13682 return; 13683 13684 action (2): 13685 double_target (index) = addr (rands (initial.value)) -> constant.value; 13686 return; 13687 13688 action (3): 13689 char_target (index) = addr (rands (initial.value)) -> char_constant.value; 13690 return; 13691 13692 action (4): 13693 char77_target (index) = addr (rands (initial.value)) -> char_constant.value; 13694 return; 13695 13696 end assign_value; 13697 13698 end initialize_symbol; 13699 13700 list_initialize_symbol: 13701 procedure (sym_pt, init_pt, end_offset); 13702 13703 dcl ( 13704 sym_pt, /* pointer to symbol */ 13705 init_pt 13706 ) pointer; /* pointer to template storage */ 13707 13708 dcl end_offset fixed bin (35); /* offset end of last stored */ 13709 13710 /* end_offset will be the last offset value assigned, and used as both input 13711* and output. The difference between the end_offset input and the first 13712* offset calculated will be a null filler. end_offset output will be the 13713* end of the area initialized to this point. */ 13714 13715 dcl boffset fixed bin (35); 13716 dcl s pointer; 13717 dcl (index, case, bsize, csize) fixed binary (18); 13718 dcl off fixed bin (35); 13719 13720 dcl 1 initial aligned automatic, 13721 2 next fixed binary (35), 13722 2 limit fixed binary (35), 13723 2 value fixed binary (35); 13724 13725 dcl 1 initial_in_polish aligned based, 13726 2 next fixed binary (35) aligned, 13727 2 limit fixed binary (35) aligned, 13728 2 value fixed binary (35) aligned; 13729 13730 dcl single_target (10000) bit (36) aligned based; 13731 13732 dcl double_target (10000) bit (72) aligned based; 13733 13734 dcl char_target (10000) character (csize) aligned based; 13735 13736 dcl char77_target (10000) character (csize) unaligned based; 13737 13738 13739 s = sym_pt; 13740 index = 1; 13741 13742 /* Develop an offset to the start of the variable area to be initialized */ 13743 13744 if s -> symbol.VLA 13745 then off = s -> symbol.location; 13746 else do; 13747 off = s -> symbol.address.offset; 13748 if s -> symbol.large_address 13749 then off = off + s -> symbol.location; 13750 end; 13751 13752 boffset = off * 36; 13753 13754 if s -> symbol.units = char_units 13755 then boffset = boffset + 9 * s -> symbol.address.char_num; 13756 13757 if s -> symbol.character 13758 then if s -> symbol.units = char_units 13759 then do; 13760 csize = s -> symbol.char_size + 1; 13761 case = 4; 13762 end; 13763 else do; 13764 csize = s -> symbol.char_size + 1; 13765 case = 3; 13766 end; 13767 else case = data_type_size (s -> symbol.data_type); 13768 13769 if ^s -> symbol.dimensioned 13770 then do; 13771 initial.value = addr (polish (s -> symbol.initial)) -> initial_in_polish.value; 13772 call list_assign_value (1); 13773 return; 13774 end; 13775 13776 initial.next = s -> symbol.initial; 13777 13778 do while (initial.next > 0); 13779 13780 /* can't use aggregate assignment because of bug 1466 */ 13781 13782 initial.value = addr (polish (initial.next)) -> initial_in_polish.value; 13783 initial.limit = addr (polish (initial.next)) -> initial_in_polish.limit; 13784 initial.next = addr (polish (initial.next)) -> initial_in_polish.next; 13785 call list_assign_value (initial.limit); 13786 index = index + initial.limit; 13787 13788 end; 13789 return; 13790 13791 list_assign_value: 13792 procedure (repeat); 13793 13794 dcl repeat fixed bin (35); 13795 13796 if initial.value = gap_value /* skip */ 13797 then return; 13798 13799 go to size_it (case); 13800 13801 size_it (1): /* single precision */ 13802 bsize = 36; 13803 off = (divide (boffset + bsize - 1, bsize, 35) + (index - 1)) * bsize; 13804 goto list_assign_create; 13805 13806 size_it (2): /* double precision */ 13807 bsize = 72; 13808 off = (divide (boffset + bsize - 1, bsize, 35) + (index - 1)) * bsize; 13809 goto list_assign_create; 13810 13811 size_it (3): /* ansi66 character aligned target */ 13812 bsize = divide (csize + 3, 4, 35) * 36; /* round up to word */ 13813 off = divide (boffset + 35, 36, 35) * 36 + (index - 1) * bsize; 13814 goto list_assign_create; 13815 13816 size_it (4): /* ansi77 character unaligned */ 13817 bsize = csize * 9; 13818 off = boffset + (index - 1) * bsize; 13819 goto list_assign_create; 13820 13821 13822 /* create the initialization entry at the specified pointer. */ 13823 13824 list_assign_create: 13825 if end_offset ^= off /* see if we formed a gap */ 13826 then do; /* filler */ 13827 init_pt -> create_init_entry.repeat = 0; /* skip */ 13828 init_pt -> create_init_entry.length = off - end_offset; 13829 init_pt = addrel (init_pt, 2); 13830 end; 13831 init_pt -> create_init_entry.length = bsize; 13832 init_pt -> create_init_entry.repeat = repeat; 13833 go to action (case); 13834 13835 action (1): 13836 addr (init_pt -> create_init_entry.datum) -> single_target (1) = addr (rands (initial.value)) -> constant.value; 13837 goto list_assign_finish; 13838 13839 action (2): 13840 addr (init_pt -> create_init_entry.datum) -> double_target (1) = addr (rands (initial.value)) -> constant.value; 13841 goto list_assign_finish; 13842 13843 action (3): 13844 addr (init_pt -> create_init_entry.datum) -> char_target (1) = 13845 addr (rands (initial.value)) -> char_constant.value; 13846 goto list_assign_finish; 13847 13848 action (4): 13849 addr (init_pt -> create_init_entry.datum) -> char77_target (1) = 13850 addr (rands (initial.value)) -> char_constant.value; 13851 goto list_assign_finish; 13852 13853 list_assign_finish: 13854 init_pt = addrel (init_pt, currentsize (init_pt -> create_init_entry)); 13855 end_offset = off + bsize * repeat; 13856 return; 13857 13858 end list_assign_value; 13859 13860 end list_initialize_symbol; 13861 13862 /**** LINKAGE SECTION GENERATION ****/ 13863 13864 init_linkage: 13865 procedure (); 13866 13867 /* This procedure is called to initialize the linkage generator. 13868* It builds the linkage_header and generates the class 3 13869* segname definition and the definition for "symbol_table". */ 13870 13871 dcl 1 def_header based aligned, 13872 2 forward bit (18) unaligned, 13873 2 backward bit (18) unaligned, 13874 2 skip bit (18) unaligned, 13875 2 flags bit (18) unaligned; 13876 13877 13878 /* initialize linkage header */ 13879 13880 link_base -> virgin_linkage_header.def_offset = bit (defrel, 18); 13881 link_base -> virgin_linkage_header.link_begin = bit (begin_links, 18); 13882 link_base -> virgin_linkage_header.linkage_section_lng = bit (link_pos, 18); 13883 link_base -> virgin_linkage_header.static_length = 13884 bit (fixed (begin_links - size (virgin_linkage_header), 18), 18); 13885 13886 link_reloc_base -> reloc (1) = rc_t; 13887 13888 /* generate definition header. the word of zeros terminating 13889* the definition chain will be at location 2 */ 13890 13891 def_base -> def_header.flags = "11"b; /* new,ignore */ 13892 def_reloc_base -> reloc (0) = rc_dp; 13893 zero_def = "000000000000000010"b; 13894 last_def = (18)"0"b; 13895 def_pos = 3; 13896 13897 /* generate definition for segname, class 3 */ 13898 13899 call generate_definition (segname, 3, zero_def); 13900 13901 /* generate definition for "symbol_table" */ 13902 13903 call generate_definition ("symbol_table", 2, "0"b); 13904 13905 addrel (def_base, seg_def) -> segname_def.defblock = last_def; 13906 13907 return; 13908 13909 end init_linkage; 13910 13911 gen_linkage: 13912 procedure (); 13913 13914 /* Generate the links for common and external references */ 13915 13916 dcl i fixed binary (18); 13917 dcl position fixed binary (15); 13918 dcl s pointer; 13919 13920 do i = begin_external_list to end_external_list - 1 by 3; 13921 s = ext_ref (i); 13922 if s -> node.allocated 13923 then if s -> node.node_type = symbol_node 13924 then if s -> symbol.initial = 0 13925 then do; 13926 position = s -> symbol.address.offset; 13927 if s -> symbol.large_address 13928 then position = position + s -> symbol.location; 13929 call compile_link (s -> symbol.name, "0"b, 0, position); 13930 end; 13931 else ; 13932 else do; 13933 13934 /* the following code is affected by PL/I bug 1599 */ 13935 /* This bug is fixed by release 23 of PL/I */ 13936 13937 if index (s -> header.block_name, "$") = 0 13938 then call compile_link (s -> header.block_name, initialize_common (s, (polish (i + 1))), 1, 13939 (s -> header.location)); 13940 else if ^s -> header.initialed 13941 then call compile_link (s -> header.block_name, "0"b, 1, (s -> header.location)); 13942 else call print_message (429, s -> header.block_name); 13943 end; 13944 end; 13945 13946 return; 13947 13948 end gen_linkage; 13949 13950 compile_link: 13951 procedure (string, grow, type, link_pos); 13952 13953 dcl string char (*) aligned, 13954 grow bit (18) aligned, 13955 type fixed binary (18), 13956 link_pos fixed binary (15); 13957 13958 dcl (seg_name, ent_name, block_type) bit (18) aligned; 13959 13960 dcl (def_ptr, link_ptr, def_reloc_ptr, link_reloc_ptr) pointer; 13961 dcl head_address fixed binary (35) based aligned; 13962 13963 dcl k fixed binary (18); 13964 13965 dcl dollar_name char (32) aligned; 13966 13967 dcl length builtin; 13968 13969 if length (string) = 0 13970 then do; 13971 13972 /* <*symbol>|0 link */ 13973 13974 block_type = "000001"b3; 13975 seg_name = "000002"b3; 13976 ent_name = "000000"b3; 13977 end; 13978 13979 else do; 13980 13981 /* ordinary link */ 13982 13983 if grow 13984 then block_type = "000005"b3; 13985 else block_type = "000004"b3; 13986 13987 k = index (string, "$"); 13988 13989 if k ^= 0 13990 then do; /* name of the form a$b */ 13991 13992 dollar_name = substr (string, 1, k - 1);/* get segment part of dollar name */ 13993 seg_name = name_assign (dollar_name); 13994 13995 /* different link required if common block name ends with $; it is illegal for */ 13996 /* external reference names to end with $. */ 13997 13998 if k = length (string) /* name ends with $ */ 13999 then do; 14000 ent_name = zero_def; /* there is no entry name */ 14001 block_type = "000003"b3; /* valid only for common block links */ 14002 end; 14003 else do; /* reference of the form a$b; get entry name */ 14004 dollar_name = substr (string, k + 1); 14005 ent_name = name_assign (dollar_name); 14006 end; 14007 end; 14008 14009 else do; /* no $ in name */ 14010 14011 ent_name = name_assign (string); 14012 14013 if type = 0 14014 then seg_name = ent_name; 14015 else seg_name = "000005"b3; 14016 end; 14017 end; 14018 14019 def_ptr = addrel (def_base, def_pos); 14020 def_reloc_ptr = addrel (def_reloc_base, def_pos); 14021 link_ptr = addrel (link_base, link_pos); 14022 link_reloc_ptr = addrel (link_reloc_base, link_pos); 14023 14024 def_ptr -> type_pair.type = block_type; 14025 def_ptr -> type_pair.trap_ptr = grow; 14026 if grow 14027 then def_reloc_ptr -> reloc (0) = rc_a_dp; 14028 14029 def_ptr -> type_pair.seg_ptr = seg_name; 14030 def_ptr -> type_pair.ext_ptr = ent_name; 14031 if type = 0 14032 then def_reloc_ptr -> reloc (1) = rc_a_dp; 14033 else def_reloc_ptr -> reloc (1) = rc_dp_dp; 14034 14035 addrel (def_ptr, 2) -> exp_word.type_ptr = bit (def_pos, 18); 14036 def_reloc_ptr -> reloc (2) = rc_dp; 14037 14038 link_ptr -> head_address = -link_pos * binary (262144, 19); 14039 link_ptr -> link.ft2 = FT2_mod; /* 46 octal */ 14040 link_reloc_ptr -> reloc (0) = rc_nlb; 14041 14042 link_ptr -> link.exp_ptr = bit (fixed (def_pos + 2, 18), 18); 14043 link_reloc_ptr -> reloc (1) = rc_dp; 14044 14045 def_pos = def_pos + 3; 14046 14047 return; 14048 14049 end compile_link; 14050 14051 name_assign: 14052 procedure (name) returns (bit (18) aligned); 14053 14054 dcl name char (*) aligned; 14055 dcl vname char (32) varying; 14056 14057 dcl 1 acc aligned based, 14058 2 count bit (9) unaligned, 14059 2 string char (n) unaligned; 14060 14061 dcl n fixed binary (9); 14062 dcl (i, old_pos) fixed binary (18); 14063 dcl p pointer; 14064 14065 dcl 1 st aligned based (polish_base), 14066 2 acc_ptrs (0:next_free_polish - 1) pointer unaligned; 14067 14068 dcl length builtin; 14069 14070 /* trim the blanks from name */ 14071 14072 vname = substr (name, 1, length (name) - verify (reverse (name), " ") + 1); 14073 14074 /* see if this acc string has already been used */ 14075 14076 do i = begin_forward_refs to hbound (acc_ptrs, 1); 14077 p = acc_ptrs (i); 14078 n = fixed (p -> acc.count, 9); 14079 if length (vname) = n 14080 then if vname = p -> acc.string 14081 then do; 14082 old_pos = fixed (rel (p), 18) - defrel; 14083 return (bit (old_pos, 18)); 14084 end; 14085 end; 14086 14087 /* build a new acc string */ 14088 14089 n = length (vname); 14090 p = addrel (def_base, def_pos); 14091 14092 if next_free_polish < polish_max_len 14093 then do; 14094 next_free_polish = next_free_polish + 1; 14095 acc_ptrs (next_free_polish - 1) = p; 14096 end; 14097 14098 p -> acc.count = bit (n, 9); 14099 p -> acc.string = vname; 14100 14101 old_pos = def_pos; 14102 def_pos = def_pos + divide (n + chars_per_word, chars_per_word, 17, 0); 14103 14104 return (bit (old_pos, 18)); 14105 14106 end name_assign; 14107 14108 initialize_common: 14109 procedure (pt, len) returns (bit (18) aligned); 14110 14111 dcl (h, s, pt, grow_pt, init_pt) pointer; 14112 dcl (len, init_val, sym) fixed binary (18); 14113 dcl ( 14114 m, /* length of LIST_TEMPLATE_INIT */ 14115 n /* length of TEMPLATE_INIT */ 14116 ) fixed bin (18); 14117 dcl grow_info bit (18) aligned; 14118 dcl use_pool bit (1) aligned; 14119 14120 dcl max_template_init_size fixed bin (18) static options (constant) init (256); 14121 28 1 /* Begin include file ... system_link_init_info.incl.pl1 ... 5/6/80 MRJ */ 28 2 28 3 28 4 28 5 /****^ HISTORY COMMENTS: 28 6* 1) change(86-05-02,Elhard), approve(86-05-02,MCR7391), 28 7* audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222): 28 8* Modified to declare DEFERRED_INIT type constant. 28 9* 2) change(86-06-24,DGHowe), approve(86-06-24,MCR7420), audit(86-11-12,Zwick), 28 10* install(86-11-20,MR12.0-1222): 28 11* added the external pointer initialization structure and the constants 28 12* required to use them. 28 13* END HISTORY COMMENTS */ 28 14 28 15 28 16 /* Modified: 82-11-17 by T. Oke to add list_init_info and LIST_TEMPLATE_INIT. */ 28 17 28 18 /* format: style3,idind25 */ 28 19 28 20 /* NOTE -------------------------------------------------- 28 21* the following structures defining initialization information can also 28 22* be found in fortran_storage.incl.pl1 definition_dcls.incl.pl1 28 23* and should be kept equivalent 28 24* ------------------------------------------------------- 28 25**/ 28 26 28 27 dcl init_info_ptr ptr; /* ptr to structure below */ 28 28 dcl init_size fixed bin (35); /* size (in words) of initialization template */ 28 29 28 30 dcl 1 init_info aligned based (init_info_ptr), 28 31 2 size fixed bin (35), /* size (in words) of data */ 28 32 2 type fixed bin, /* type of initialization: see below */ 28 33 2 init_template (init_size refer (init_info.size)) fixed bin (35); 28 34 28 35 dcl 1 init_info_single_word aligned based (init_info_ptr), 28 36 /* for convenience of people like ssi */ 28 37 2 size fixed bin (19), /* = 1 */ 28 38 2 type fixed bin, /* = TEMPLATE_INIT */ 28 39 2 init_template (1) fixed bin (35); /* = value */ 28 40 28 41 dcl 1 list_init_info aligned based, 28 42 2 size fixed bin (35), /* length of variable */ 28 43 2 type fixed bin, /* LIST_TEMPLATE_INIT */ 28 44 2 pad bit (18) unaligned, 28 45 2 list_size fixed bin (18) unsigned unaligned, 28 46 /* size in words of template */ 28 47 2 template (0 refer (list_init_info.list_size)) bit (36); 28 48 /* first create_entry position */ 28 49 28 50 /* A list template consists of a series of entries with the following 28 51* description, concatenated together. n_bits and datum are bit items, 28 52* to permit a wide range of inputs. 28 53* 28 54* 1. A 'repeat' of '0' signifies skipping of 'n_bits' bits. 28 55* 2. A 'n_bits' of '0' signifies the last item of the list. 28 56* 28 57* COMMON, VLA's, and LA's are presumed to start at the base pointer 28 58* of their particular storage section. */ 28 59 28 60 dcl 1 list_template_entry aligned based, 28 61 2 n_bits fixed bin (35) aligned, /* size of datum */ 28 62 2 mbz bit (3) unaligned, /* future expansion */ 28 63 2 init_type fixed bin (3) unsigned unaligned, /* 0 normal init, 1 ptr init, 2 packed ptr init */ 28 64 2 repeat fixed bin (30) unsigned unaligned, 28 65 /* number of times to repeat datum */ 28 66 2 datum bit (init_n_bits_in_datum refer (list_template_entry.n_bits)); 28 67 28 68 /* list_template_entry_ptr is defined such that it can be used as an 28 69* automatic definition overlay with a fixed size datum. it has a declared 28 70* size of 72 to allow for the its pointer sixe of 72 bits. 28 71**/ 28 72 28 73 dcl 1 list_template_entry_ptr aligned based, 28 74 2 n_bits fixed bin (35) aligned, 28 75 2 mbz bit(3) unaligned, 28 76 2 init_type fixed bin (3) unsigned unaligned, 28 77 2 repeat fixed bin (30) unsigned unaligned, 28 78 2 datum bit(72); 28 79 28 80 /* the pointer_init_template represents the initialization information 28 81* for ITS and packed pointers. Both pointer types require the entire 28 82* 72 bit structure. 28 83**/ 28 84 28 85 dcl 1 pointer_init_template based, 28 86 2 ptr_type fixed bin (18) unsigned unaligned, /* 0 text section, 1 linkage section, 2 static section */ 28 87 2 section_offset fixed bin (18) unsigned unaligned, /* offset to item in specified section */ 28 88 2 word_offset fixed bin (18) unsigned unaligned, /* word offset from section item to target */ 28 89 2 mbz bit (12) unaligned, 28 90 2 bit_offset fixed bin (6) unsigned unaligned; /* bit offset from section item|word offset to target */ 28 91 28 92 28 93 dcl init_n_bits_in_datum fixed bin (35); 28 94 28 95 dcl NO_INIT fixed bin static options (constant) init (0); 28 96 dcl TEMPLATE_INIT fixed bin static options (constant) init (3); 28 97 dcl EMPTY_AREA_INIT fixed bin static options (constant) init (4); 28 98 dcl LIST_TEMPLATE_INIT fixed bin static options (constant) init (5); 28 99 dcl INIT_DEFERRED fixed bin static options (constant) init (6); 28 100 dcl ITS_PTR_INIT fixed bin (3) unsigned static options (constant) init(1); 28 101 dcl PACKED_PTR_INIT fixed bin (3) unsigned static options (constant) init(2); 28 102 dcl PTR_INIT_TEXT fixed bin (17) static options (constant) init(0); 28 103 dcl PTR_INIT_LOT fixed bin (17) static options (constant) init(1); 28 104 dcl PTR_INIT_ISOT fixed bin (17) static options (constant) init(2); 28 105 28 106 28 107 /* End include file ... system_link_init_info.incl.pl1 */ 14122 14123 14124 14125 14126 h = pt; 14127 n = len; 14128 14129 if h -> header.alignment.character 14130 then n = divide (n + chars_per_word - 1, chars_per_word, 18, 0); 14131 14132 if h -> header.initialed & n <= max_template_init_size 14133 then if fixed (rel (addrel (def_base, def_pos + n + mod (def_pos, 2)))) > max_linkage_size 14134 then do; /* CANNOT INIT ON PAIN OF DEATH */ 14135 call print_message (469, h -> header.block_name, max_linkage_size - bias); 14136 h -> header.initialed = "0"b; /* PULL OUT THE RUG */ 14137 end; 14138 14139 14140 if h -> header.initialed 14141 then def_pos = def_pos + mod (def_pos, 2); 14142 14143 grow_info = bit (def_pos, 18); 14144 grow_pt = addrel (def_base, grow_info); 14145 init_pt = addrel (grow_pt, 2); 14146 14147 init_val = NO_INIT; 14148 14149 if h -> header.initialed 14150 then if n > max_template_init_size 14151 then do; 14152 m = 0; /* presume no template generated */ 14153 init_val = LIST_TEMPLATE_INIT; 14154 call list_initialize (addrel (init_pt, 1), fixed (rel (h), 18), m); 14155 grow_pt -> list_init_info.list_size = m; 14156 end; 14157 else do; 14158 init_val = TEMPLATE_INIT; 14159 do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0); 14160 s = addr (rands (sym)); 14161 if s -> symbol.initial ^= 0 14162 then call initialize_symbol (s, init_pt); 14163 end; 14164 end; 14165 14166 use_pool = init_val = NO_INIT & n <= hbound (def_pool, 1); 14167 if use_pool 14168 then if def_pool (n) ^= 0 14169 then return (bit (def_pool (n), 18)); 14170 14171 grow_pt -> init_info.size = n; 14172 grow_pt -> init_info.type = init_val; 14173 14174 if use_pool 14175 then def_pool (n) = def_pos; 14176 14177 def_pos = def_pos + 2; 14178 if init_val = TEMPLATE_INIT 14179 then def_pos = def_pos + n; 14180 else if init_val = LIST_TEMPLATE_INIT 14181 then def_pos = def_pos + m + 1; 14182 return (grow_info); 14183 14184 end initialize_common; 14185 14186 /**** DEFINITION SECTION ****/ 14187 14188 generate_definition: 14189 procedure (name, class, value); 14190 14191 dcl name char (*) aligned, /* symbol for definition */ 14192 class fixed binary (3), /* class of definition */ 14193 value bit (18) aligned; /* value of definition */ 14194 14195 dcl (def_ptr, def_reloc_ptr) pointer; 14196 dcl (b18, pos) bit (18) aligned; 14197 14198 dcl rel_code (0:3) aligned bit (18) internal static options (constant) initial ("000000000000010000"b, 14199 /* text */ 14200 "000000000000010010"b, /* link 18 */ 14201 "000000000000010110"b, /* symbol */ 14202 "000000000000010101"b); /* definition */ 14203 14204 14205 b18 = name_assign (name); 14206 14207 pos = bit (def_pos, 18); 14208 def_ptr = addrel (def_base, pos); 14209 def_reloc_ptr = addrel (def_reloc_base, pos); 14210 14211 if last_def 14212 then def_ptr -> definition.backward = last_def; 14213 else def_ptr -> definition.backward = zero_def; 14214 14215 addrel (def_base, last_def) -> definition.forward = pos; 14216 14217 def_ptr -> definition.forward = zero_def; 14218 14219 def_ptr -> definition.new = "1"b; 14220 def_ptr -> definition.symbol = b18; 14221 def_ptr -> definition.value = value; 14222 14223 def_ptr -> definition.class = bit (class, 3); 14224 14225 if class = 3 14226 then seg_def = pos; 14227 else do; 14228 def_ptr -> definition.segname = seg_def; 14229 def_ptr -> definition.entry = class = 0; 14230 end; 14231 14232 def_reloc_ptr -> reloc (0) = rc_dp_dp; 14233 def_reloc_ptr -> reloc (2) = rc_dp_dp; 14234 def_reloc_ptr -> reloc (1) = rel_code (class); 14235 14236 last_def = pos; 14237 def_pos = def_pos + 3; 14238 14239 end generate_definition; 14240 14241 gen_entry_defs: 14242 procedure (); 14243 14244 /* Generates entry definitions and finishes up entry sequences */ 14245 14246 dcl desc fixed bin (18); 14247 dcl (s, def_ptr) pointer; 14248 dcl (sym, stack_size) fixed binary (18); 14249 dcl ent_pos fixed binary (18); 14250 14251 14252 stack_size = divide (last_auto_loc + 15, 16, 17, 0) * 16; 14253 14254 do sym = first_entry_name repeat s -> symbol.next_symbol while (sym > 0); 14255 s = addr (rands (sym)); 14256 ent_pos = s -> label.location; /* a slight kludge */ 14257 14258 /* fill in stack_size (must be multiple of 16) */ 14259 14260 text_halfs (ent_pos).left = stack_size; 14261 14262 /* generate entry definition */ 14263 14264 call generate_definition (s -> symbol.name, 0, bit (ent_pos, 18)); 14265 14266 reloc_halfs (ent_pos - 1).left = rc_dp; 14267 14268 unspec (text_halfs (ent_pos - 1).left) = last_def; 14269 def_ptr = addrel (def_base, last_def); 14270 14271 if assembly_list 14272 then a_name (ent_pos - 1) = -1; /* tell listing generator this is not an inst */ 14273 14274 def_ptr -> definition.retain = "1"b; 14275 14276 /* process entry definitions */ 14277 14278 parm_desc_ptrsp = addr (text_halfs (text_halfs (ent_pos - 2).left)); 14279 do i = 1 to parm_desc_ptrs.n_args; 14280 desc = parm_desc_ptrs.descriptor_relp (i); 14281 parm_desc_ptrs.descriptor_relp (i) = addr (rands (desc)) -> label.location; 14282 end; 14283 end; 14284 14285 end gen_entry_defs; 14286 14287 end code_generator; 14288 14289 end fort_optimizing_cg; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 05/30/90 1534.7 fort_optimizing_cg.pl1 >spec>install>1011>fort_optimizing_cg.pl1 40 1 11/10/88 1550.9 fort_nodes.incl.pl1 >ldd>include>fort_nodes.incl.pl1 41 2 03/27/82 0524.8 fort_opt_nodes.incl.pl1 >ldd>include>fort_opt_nodes.incl.pl1 43 3 03/27/82 0539.3 fort_listing_nodes.incl.pl1 >ldd>include>fort_listing_nodes.incl.pl1 45 4 08/04/86 2115.0 fort_system_constants.incl.pl1 >ldd>include>fort_system_constants.incl.pl1 48 5 08/04/86 2115.0 fort_shared_vars.incl.pl1 >ldd>include>fort_shared_vars.incl.pl1 50 6 08/06/87 1253.7 fort_options.incl.pl1 >ldd>include>fort_options.incl.pl1 53 7 03/27/82 0539.4 fort_cg_vars.incl.pl1 >ldd>include>fort_cg_vars.incl.pl1 55 8 11/24/86 1326.9 definition.incl.pl1 >ldd>include>definition.incl.pl1 56 9 10/30/80 1748.7 segname_def.incl.pl1 >ldd>include>segname_def.incl.pl1 59 10 03/27/82 0537.1 fort_symtab_parms.incl.pl1 >ldd>include>fort_symtab_parms.incl.pl1 60 11 03/10/77 1445.4 long_profile.incl.pl1 >ldd>include>long_profile.incl.pl1 83 12 03/27/82 0537.1 fort_utilities.incl.pl1 >ldd>include>fort_utilities.incl.pl1 12-11 13 03/27/82 0537.8 fort_create_node.incl.pl1 >ldd>include>fort_create_node.incl.pl1 12-37 14 10/30/80 1748.7 relocation_bits.incl.pl1 >ldd>include>relocation_bits.incl.pl1 649 15 07/27/83 1010.0 linkdcl.incl.pl1 >ldd>include>linkdcl.incl.pl1 650 16 08/05/77 1122.5 object_map.incl.pl1 >ldd>include>object_map.incl.pl1 651 17 10/30/80 1748.7 relbts.incl.pl1 >ldd>include>relbts.incl.pl1 652 18 10/30/80 1748.7 reloc_lower.incl.pl1 >ldd>include>reloc_lower.incl.pl1 653 19 11/26/79 1420.6 its.incl.pl1 >ldd>include>its.incl.pl1 654 20 10/30/80 1748.7 profile_entry.incl.pl1 >ldd>include>profile_entry.incl.pl1 655 21 10/12/83 1615.6 fortran_storage.incl.pl1 >ldd>include>fortran_storage.incl.pl1 656 22 10/26/88 1355.5 std_descriptor_types.incl.pl1 >ldd>include>std_descriptor_types.incl.pl1 1084 23 10/30/80 1748.7 relocation_bits.incl.pl1 >ldd>include>relocation_bits.incl.pl1 2478 24 10/30/80 1748.7 relocation_bits.incl.pl1 >ldd>include>relocation_bits.incl.pl1 2612 25 12/21/84 1337.8 fort_single_inst_names.incl.pl1 >ldd>include>fort_single_inst_names.incl.pl1 2850 26 10/30/80 1748.7 relocation_bits.incl.pl1 >ldd>include>relocation_bits.incl.pl1 12678 27 03/27/82 0537.1 fort_opt_utilities.incl.pl1 >ldd>include>fort_opt_utilities.incl.pl1 14122 28 11/24/86 1326.9 system_link_init_info.incl.pl1 >ldd>include>system_link_init_info.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. A 000024 external static bit(1) array level 3 in structure "fort_instruction_info_$fort_instruction_info_" packed packed unaligned dcl 2578 in procedure "interpreter" ref 6091 6137 6190 6193 A 000400 constant fixed bin(18,0) initial dcl 2620 in procedure "interpreter" set ref 3799* 6193 8750* 8783 8786 8790 8933* 9037 9038 9039 9041 9060 9061 9061 9092* 9201 9205 9205 9303* 12812* 12825* AL_mod 000612 constant bit(6) initial dcl 614 set ref 7090 8750 8776 8807 12811* 12817* 12822* 12824* Area_create_first 3144 based fixed bin(18,0) level 2 dcl 47 set ref 1106* 2183 2184 2264 2264* 4915 4945 4952 Area_create_last 3145 based fixed bin(18,0) level 2 dcl 47 set ref 2270 2275* Area_init_first 3146 based fixed bin(18,0) level 2 dcl 47 set ref 1106* 4956 4962 BASE constant fixed bin(17,0) initial dcl 609 set ref 4760* 12013* 12027* 12029* DL_mod 000613 constant bit(6) initial dcl 614 set ref 6105 6267 6313 6347 12936* 12955* 12974* DU_mod 074410 constant bit(6) initial dcl 614 ref 6279 6841 EAQ 000753 constant fixed bin(18,0) initial dcl 2620 set ref 3807* 3900* 4408* 5839* 6190 6212 6212 6212 8928* 8931 9065 9068 9070 9072 9073 9083 9298* 9301 9778* 12926* 12945* 12962* ERROR 000740 constant fixed bin(18,0) initial dcl 2594 set ref 2880 2894 3313 3321 3334* 3979* 4392 FT2_mod constant bit(6) initial dcl 614 ref 14039 IND 000747 constant fixed bin(18,0) initial dcl 2620 set ref 3510 3513 3524 3524 3829 3902* 8790 8925 8928 9024 9024 9027 9031 9035 9036* 9107 9167 9195 9215 9298 9401 9407 9409 9410 9410 9443 9779* INDEX constant fixed bin(17,0) initial dcl 609 set ref 4718* 10076 12014* 12038* 12040* 12100 12132 12209 12239 ITP_mod constant bit(6) initial dcl 614 ref 923 11632 K256 0(23) based bit(1) level 3 packed packed unaligned dcl 21-23 set ref 2251* LA 4(01) based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 6660 LA 2(04) based bit(1) level 2 in structure "header" packed packed unaligned dcl 1-436 in procedure "fort_optimizing_cg" ref 2249 LA 0(21) based bit(1) level 3 in structure "create_entry" packed packed unaligned dcl 21-23 in procedure "code_generator" set ref 2249* LA_chain 57(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 ref 1154 LIST_TEMPLATE_INIT constant fixed bin(17,0) initial dcl 28-98 ref 14153 14180 NO_INIT constant fixed bin(17,0) initial dcl 28-95 ref 14147 14166 Q 0(01) 000024 external static bit(1) array level 3 in structure "fort_instruction_info_$fort_instruction_info_" packed packed unaligned dcl 2578 in procedure "interpreter" ref 6091 6137 6190 6196 Q 000354 constant fixed bin(18,0) initial dcl 2620 in procedure "interpreter" set ref 3803* 4224* 6196 8433* 8438 8748* 8783 8788 8790 8934* 8966 9167 9304* 10937* 11052* 11083* 11305* 11325* 11507* 11601* 12800* 12827* 12921* QL_mod constant bit(6) initial dcl 614 ref 4814 6784 7091 7103 8748 8774 8805 11326 QU_mod constant bit(6) initial dcl 614 ref 7104 RHS 006645 automatic fixed bin(35,0) dcl 12842 set ref 12905* 12907* 12907* RI_mod constant bit(6) initial dcl 614 ref 1165 1506 1541 1630 11638 TEMPLATE_INIT constant fixed bin(17,0) initial dcl 28-96 ref 14158 14178 VLA 1(06) based bit(1) array level 4 in structure "arg_desc" packed packed unaligned dcl 1-130 in procedure "fort_optimizing_cg" set ref 11705* 11749 11817* VLA 2(03) based bit(1) level 2 in structure "header" packed packed unaligned dcl 1-436 in procedure "fort_optimizing_cg" ref 1930 2250 VLA 004137 automatic bit(1) packed unaligned dcl 7188 in procedure "base_man_load_pr" set ref 7198* 7200* 7202* 7204 7233 VLA 4 based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 1438 1503 4130 4304 4926 6583 6638 6655 6991 6993 7198 7200 10571 11705 11749 11817 13744 VLA 000103 automatic bit(1) packed unaligned dcl 6942 in procedure "base_man_load_any_pr" set ref 6991* 6993* 6995* 7011 VLA 0(22) based bit(1) level 3 in structure "create_entry" packed packed unaligned dcl 21-23 in procedure "code_generator" set ref 2250* VLA_base_addressor 4 based fixed bin(18,0) level 2 in structure "dimension" dcl 1-383 in procedure "fort_optimizing_cg" ref 1442 4138 VLA_base_addressor 7 based fixed bin(18,0) level 2 in structure "header" dcl 1-436 in procedure "fort_optimizing_cg" ref 1238 2125 2125 2131 2131 13478 13489 VLA_chain 57 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 ref 1219 VLA_is_256K 115(03) based bit(1) level 4 packed packed unaligned dcl 47 ref 1449 1933 2135 2251 4140 VLA_words_per_seg constant fixed bin(14,0) initial dcl 2650 ref 4153 X0_mod constant bit(6) initial dcl 614 set ref 12934* 12937* 12953* 12957* 12971* 12976* X1_mod 000611 constant bit(6) initial dcl 614 set ref 12972* 12975* XR 0(09) 000024 external static bit(8) array level 3 packed packed unaligned dcl 2578 ref 6208 6208 a 005704 automatic pointer dcl 11666 set ref 11695* 11696 11700 11704 11705 11708 11709 11718* 11720 11723 11723 11737 11737 11747 11749 11753 11756 a9bd 000517 constant fixed bin(18,0) initial dcl 25-16 set ref 7253* 7262* 7264* 7272* 7281* a_base 000224 automatic pointer dcl 498 set ref 676* 678* 1952 2161 3753 3762 4127 4143 4156 4166 4181 4196 4270 4301 4355 4939 4966 5992 5995 6154 6157 6460 6463 7120 14271 a_data_type 000100 automatic fixed bin(4,0) dcl 12-15 set ref 12-40* 12-43 12-43 12-43 12-45 12-45 12-47 12-65 12-81 a_name based fixed bin(18,0) array dcl 540 set ref 1952* 2161* 3753* 3762* 4127* 4143* 4156* 4166* 4181* 4196* 4270* 4301* 4355* 4939* 4966* 5992* 5995* 6154* 6157* 6460* 6463* 7120* 14271* a_new parameter fixed bin(18,0) dcl 5535 ref 5527 5542 a_new_state parameter structure level 1 dcl 9514 set ref 9509 9519 9525 a_opnd parameter fixed bin(18,0) dcl 10395 ref 10390 10400 a_ref 005532 automatic fixed bin(18,0) dcl 11138 set ref 11141* 11145* 11175* 11176* 11184 a_state parameter fixed bin(18,0) dcl 9386 set ref 9380 9416* 9419 9422 a_temp parameter fixed bin(18,0) dcl 5534 ref 5527 5540 a_value 000102 automatic bit(72) dcl 12-16 set ref 12-41* 12-51 12-52 12-54 12-54 12-65 12-85 abs builtin function dcl 645 ref 961 acc based structure level 1 dcl 14057 acc_ptrs based pointer array level 2 packed packed unaligned dcl 14065 set ref 14076 14077 14095* adam 005152 automatic pointer dcl 10015 in procedure "assign_register" set ref 10026* 10035* 10037 10043 10054 adam 006110 automatic pointer dcl 12113 in procedure "ok_to_allocate" set ref 12119* 12121 12129 12145 adam 006140 automatic pointer dcl 12188 in procedure "allocate" set ref 12199* 12201 12212 12213 12215* 12216* 12221 12222 12234 12236 12259 add_base 000464 constant fixed bin(18,0) initial array dcl 25-16 ref 7052 7448 7479 addr builtin function dcl 645 in procedure "code_generator" ref 676 729 749 750 803 803 867 872 891 1027 1029 1034 1036 1117 1133 1143 1156 1195 1206 1221 1238 1278 1293 1308 1323 1371 1382 1394 1426 1442 1443 1530 1606 1624 1643 1661 1674 1728 1734 1740 1746 1772 1892 1932 1948 2052 2125 2125 2131 2131 2160 2272 2296 2303 2309 2339 2343 2364 2453 2459 2481 2491 2882 2885 2888 2908 2913 2917 2924 2931 2934 2940 2950 2972 2973 3062 3065 3083 3083 3098 3100 3117 3178 3178 3195 3205 3206 3209 3217 3218 3221 3229 3230 3306 3378 3397 3415 3423 3432 3453 3471 3473 3495 3498 3507 3513 3536 3542 3547 3554 3554 3566 3576 3576 3587 3612 3615 3618 3678 3724 3738 3753 3762 3789 3789 3794 3794 3829 3829 3839 3839 3848 3848 3848 3848 3940 3950 3951 4000 4036 4115 4125 4138 4139 4176 4190 4206 4219 4221 4270 4295 4299 4317 4317 4319 4329 4334 4334 4337 4345 4355 4372 4379 4439 4464 4470 4473 4481 4481 4502 4529 4542 4547 4547 4554 4563 4571 4598 4601 4604 4611 4614 4617 4623 4633 4680 4705 4705 4724 4785 4785 4785 4805 4820 4824 4831 4892 4899 4926 4926 5050 5296 5384 5385 5387 5388 5389 5390 5394 5395 5417 5429 5431 5433 5433 5438 5449 5471 5473 5474 5501 5541 5543 5573 5626 5699 5703 5733 5740 5763 5768 5768 5769 5785 5806 5835 6015 6039 6112 6118 6118 6248 6253 6290 6332 6405 6518 6518 6518 6520 6520 6563 6564 6564 6575 6620 6665 6670 6694 6882 6882 6990 6993 7013 7013 7077 7081 7144 7194 7200 7325 7848 7859 7905 7905 7960 7966 8080 8142 8242 8333 8391 8393 8461 8463 8470 8509 8511 8511 8511 8629 8633 8635 8654 8709 8821 8854 8870 8881 8883 8921 8966 8966 8980 9027 9061 9073 9121 9170 9215 9252 9252 9273 9276 9322 9344 9458 9461 9470 9482 9494 9525 9535 9546 9547 9547 9564 9564 9566 9566 9567 9568 9569 9570 9571 9610 9612 9612 9717 9719 9719 9737 9737 9752 9752 9783 9821 9856 9915 9971 9971 10211 10232 10264 10264 10270 10270 10276 10276 10307 10307 10327 10327 10338 10338 10383 10401 10406 10429 10546 10560 10583 10586 10590 10618 10637 10637 10702 10706 11104 11151 11164 11248 11267 11268 11300 11302 11314 11318 11346 11348 11348 11367 11385 11385 11421 11422 11429 11470 11481 11502 11523 11555 11594 11596 11606 11641 11669 11677 11678 11695 11699 11718 11728 11737 11786 11787 11789 11803 11811 11851 11855 11893 11952 11971 12315 12377 12385 12385 12397 12424 12441 12467 12483 12508 12570 12581 12582 12601 12621 12631 12657 12658 12660 27-13 27-82 27-114 27-138 27-139 27-149 27-165 27-166 27-220 27-222 27-249 27-290 12686 12700 12738 12744 12758 12761 12761 12770 12773 12773 12848 12854 12874 12877 12877 12883 12886 12886 12903 12905 12993 13027 13027 13030 13041 13043 13075 13083 13086 13108 13190 13228 13277 13285 13291 13297 13298 13338 13347 13350 13385 13434 13442 13464 13469 13477 13478 13488 13489 13500 13520 13541 13544 13569 13576 13632 13649 13662 13663 13664 13680 13684 13688 13692 13771 13782 13783 13784 13835 13835 13839 13839 13843 13843 13848 13848 14160 14255 14278 14281 addr builtin function dcl 12-18 in procedure "create_constant" ref 12-51 12-52 12-54 12-54 12-63 12-80 12-91 addr builtin function dcl 13-17 in procedure "create_node" ref 13-24 13-25 addr_hold 2(18) based bit(18) level 2 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 2146* 7112 addr_hold 2(18) based bit(18) level 2 in structure "node" packed packed unaligned dcl 1-63 in procedure "fort_optimizing_cg" set ref 6598* 6643 7161 8726 9564* addr_hold 2(18) based bit(18) level 2 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "fort_optimizing_cg" set ref 5580* 5580 5712 5813* 7593 addrel builtin function dcl 645 ref 741 742 761 762 769 770 809 829 872 902 921 1199 1199 1270 1270 2186 2236 2270 10509 13470 13479 13481 13490 13492 13508 13521 13521 13582 13627 13829 13853 13905 14019 14020 14021 14022 14035 14090 14132 14144 14145 14154 14154 14208 14209 14215 14269 address 007054 automatic pointer dcl 13595 in procedure "initialize_symbol" set ref 13619* 13627* 13627 13632* 13632 13680 13684 13688 13692 address 1 based structure level 2 in structure "node" dcl 1-63 in procedure "fort_optimizing_cg" set ref 5997 5997 6150 6159 6444 6451 6465 6598 6624 7161 8726 9564 11641 address 1 based structure level 2 in structure "temporary" dcl 1-1005 in procedure "fort_optimizing_cg" set ref 5508* 5556 5583* 5583 5601* 5664 5700* 5712* 5813 5816* 11248 11346* 13089* address 000111 automatic bit(36) dcl 6946 in procedure "base_man_load_any_pr" set ref 6978* 6979* 6985* 7021* 7022* 7024* 7030* 7034* 7049* address 1 based structure level 2 in structure "array_ref" dcl 1-155 in procedure "fort_optimizing_cg" set ref 10574* 10616* 10621* 10650 address 1 based structure level 2 in structure "symbol" dcl 1-844 in procedure "fort_optimizing_cg" set ref 1241* 1399* 1446* 1894* 2146 6698* 6698 7112 10621 address parameter fixed bin(18,0) dcl 5926 in procedure "emit_with_tag" ref 5921 5934 address 1 based structure level 2 in structure "constant" dcl 1-256 in procedure "fort_optimizing_cg" set ref 6017 address 1 based structure level 2 in structure "char_constant" dcl 1-316 in procedure "fort_optimizing_cg" address parameter bit(36) dcl 5960 in procedure "emit_c_a" ref 5954 5965 address 1 based structure level 2 in structure "header" dcl 1-436 in procedure "fort_optimizing_cg" set ref 1160* 1226* 1241 1297* 1349* 1894 address 004251 automatic bit(36) dcl 8196 in procedure "xr_man_add_const" set ref 8201* 8202* 8203* 8210* address 1 based structure level 2 in structure "label" dcl 1-530 in procedure "fort_optimizing_cg" address_in_base 111 based bit(1) level 3 in structure "loop_state" dcl 2716 in procedure "interpreter" ref 9920 address_in_base 111 parameter bit(1) level 3 in structure "existing_state" dcl 9514 in procedure "merge_state" set ref 9669* address_in_base 0(21) based bit(1) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "fort_optimizing_cg" set ref 6555 6996* 7145* 8711 8732* 9571* address_in_base 0(21) based bit(1) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "fort_optimizing_cg" set ref 3221 3229* 3230* 5845* 11331 address_in_base 111 004574 automatic bit(1) level 3 in structure "new_state" dcl 9514 in procedure "merge_state" set ref 9556 9669 address_in_base 111 based bit(1) level 3 in structure "machine_state" dcl 1-620 in procedure "fort_optimizing_cg" set ref 10089* address_in_base 111 001511 automatic bit(1) level 3 in structure "current_ms" dcl 2714 in procedure "interpreter" set ref 5844* 6997* 9692 9773 9920* 10274 address_in_base 111 parameter bit(1) level 3 in structure "affected_ms" dcl 10301 in procedure "drop_all_ms_ref_counts" ref 10334 addressing_bits 0(14) based structure level 2 in structure "constant" packed packed unaligned dcl 1-256 in procedure "fort_optimizing_cg" addressing_bits 0(14) based structure level 2 in structure "node" packed packed unaligned dcl 1-63 in procedure "fort_optimizing_cg" addressing_bits 0(14) based structure level 2 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "fort_optimizing_cg" addressing_bits 0(14) based structure level 2 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "fort_optimizing_cg" set ref 5504* 5578* 5578 5578 addressing_bits 0(14) based structure level 2 in structure "label" packed packed unaligned dcl 1-530 in procedure "fort_optimizing_cg" addressing_bits 0(14) based structure level 2 in structure "header" packed packed unaligned dcl 1-436 in procedure "fort_optimizing_cg" set ref 1903 addressing_bits 0(14) based structure level 2 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 1903* addressing_bits 0(14) based structure level 2 in structure "char_constant" packed packed unaligned dcl 1-316 in procedure "fort_optimizing_cg" adesc 005702 automatic fixed bin(18,0) dcl 11665 set ref 11694* 11695 adfx1 000530 constant fixed bin(18,0) initial dcl 25-16 set ref 4211 11064 11316* adlx0 constant fixed bin(18,0) initial dcl 25-16 ref 8523 adq constant bit(10) initial dcl 6234 ref 6299 6302 affected_ms parameter structure level 1 dcl 10301 set ref 10296 aliasable 2(03) based bit(1) level 2 packed packed unaligned dcl 1-844 set ref 4040 12519 12703 alignment 0(30) based structure level 3 packed packed unaligned dcl 1-436 all_xrs_globally_assigned 25(21) based bit(1) level 3 packed packed unaligned dcl 2-100 set ref 4671 4710 12046* 12244* alloc_auto_adj constant fixed bin(14,0) initial dcl 2650 ref 4214 alloc_auto_cleanup 000161 automatic bit(1) dcl 484 set ref 1108* 1671 2261* 4933 alloc_length 005542 automatic fixed bin(18,0) dcl 11204 set ref 11212* 11215* 11215 11240* alloc_ps 000135 automatic bit(1) dcl 1082 set ref 1108* 1138* 1138 1640 allocate 0(25) based bit(1) level 4 in structure "node" packed packed unaligned dcl 1-63 in procedure "fort_optimizing_cg" set ref 1394* 6321* 13354* 13442* allocate 0(25) based bit(1) level 4 in structure "constant" packed packed unaligned dcl 1-256 in procedure "fort_optimizing_cg" ref 868 allocate 0(25) based bit(1) level 4 in structure "char_constant" packed packed unaligned dcl 1-316 in procedure "fort_optimizing_cg" ref 892 allocate 0(25) based bit(1) level 5 in structure "header" packed packed unaligned dcl 1-436 in procedure "fort_optimizing_cg" ref 1157 1222 1294 1324 allocate 0(25) based bit(1) level 5 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 1393* 1397 1627* 1646* 1677* 2455* 4191 13289* allocate 0(25) based bit(1) level 4 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "fort_optimizing_cg" set ref 5506* allocate_char_string constant fixed bin(14,0) initial dcl 2650 ref 11228 allocate_symbol_name 000126 automatic fixed bin(17,0) dcl 1-525 set ref 661* 1623 1623 1642 1642 1660 1660 1673 1673 2452 2452 2939 2939 2949 2949 13284 13284 allocated 0(17) based bit(1) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "fort_optimizing_cg" ref 4307 6323 13922 allocated 0(17) based bit(1) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "fort_optimizing_cg" set ref 5506* allocated 0(17) based bit(1) level 3 in structure "header" packed packed unaligned dcl 1-436 in procedure "fort_optimizing_cg" set ref 1161* 1224* 1298* 1358* allocated 0(17) based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 1028* 1240* 1383 1445* 1597* 1627* 1646* 1677* 1754* 2943* 6696 6699* 10702 11470 allocated 0(17) based bit(1) level 3 in structure "char_constant" packed packed unaligned dcl 1-316 in procedure "fort_optimizing_cg" set ref 892 906* 2911* allocated 0(17) based bit(1) level 3 in structure "constant" packed packed unaligned dcl 1-256 in procedure "fort_optimizing_cg" set ref 868 874* allocated 0(17) based bit(1) level 3 in structure "label" packed packed unaligned dcl 1-530 in procedure "fort_optimizing_cg" set ref 1029* 1037* 4470 10386* allocated 0(17) based bit(1) level 3 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "fort_optimizing_cg" set ref 2927* alr 000427 constant fixed bin(18,0) initial dcl 25-16 set ref 12934* 12953* 12971* 12972* alters 000024 external static structure array level 2 packed packed unaligned dcl 2578 always_completely_set 25 based pointer level 2 packed packed unaligned dcl 2-46 ref 10177 amount parameter fixed bin(18,0) dcl 5487 in procedure "create_temp" ref 5481 5494 amount parameter fixed bin(18,0) dcl 5406 in procedure "get_temp" ref 5401 5408 amt 000126 automatic fixed bin(18,0) dcl 5488 in procedure "create_temp" set ref 5494* 5497 5499 5513 5521* amt 000112 automatic fixed bin(18,0) dcl 5406 in procedure "get_temp" set ref 5408* 5410 5412 5429 5453* amt parameter fixed bin(17,0) dcl 861 in procedure "alloc_constants" ref 856 864 872 amt 000317 automatic fixed bin(18,0) dcl 534 in procedure "code_generator" set ref 900* 902 905 920 amt parameter fixed bin(18,0) dcl 27-46 in procedure "get_quad_space" ref 27-44 27-51 analyzing 000632 automatic bit(1) dcl 2504 set ref 2854* 2856 3062 3714 3722 3740 4014 4061 4678 4718 4760 4796 4814 5385 5549 5558 5629 5783 5946 5962 5987 6011 6057 6096 6118 6142 6457 6460 6465 6564 6576 6624 6696 6882 6953 7015 7043 7084 7297 7302 7354 7384 7500 7542 7700 8007 8038 8054 8073 8088 8126 8224 8286 8306 8548 8688 8718 9547 10195 10213 10236 10245 10452 10550 11154 11167 11300 11594 13001 anq 000656 constant fixed bin(18,0) initial dcl 25-16 set ref 11483* 11494* 11502* 11598* 12793* 12919* ansi_77 11(30) based bit(1) level 3 packed packed unaligned dcl 1-753 ref 3435 4889 5395 aos 000646 constant fixed bin(18,0) initial dcl 25-16 set ref 10472* ap 005736 automatic pointer dcl 11782 set ref 11803* 11805 11806 11808 11808 11809 11811 11812 11816 11817 11820 11821 11832 11833 11834 arg parameter pointer array dcl 6868 in procedure "make_both_addressable" ref 6862 6875 arg 004022 automatic pointer array dcl 6373 in procedure "emit_eis" set ref 6405* 6412* 6444 6451 6457 6460 6460 6465 6465* 6467 6467 6467* 6479 6514 arg 1 based structure array level 2 in structure "arg_desc" dcl 1-130 in procedure "fort_optimizing_cg" set ref 11808* 11808 11833* arg1 006646 automatic fixed bin(18,0) dcl 12843 in procedure "lhs_fld" set ref 12847* 12848 12850* 12883 12886 12948* 12965* arg1 006625 automatic fixed bin(18,0) dcl 12734 in procedure "rhs_fld" set ref 12737* 12738 12740* 12770 12773 12816* 12821* arg1_is_const 006655 automatic bit(1) initial packed unaligned dcl 12844 in procedure "lhs_fld" set ref 12844* 12885* 12891 12924 arg1_is_const 006633 automatic bit(1) initial packed unaligned dcl 12735 in procedure "rhs_fld" set ref 12735* 12772* 12778 12806 arg2 006647 automatic fixed bin(18,0) dcl 12843 in procedure "lhs_fld" set ref 12853* 12854 12856* 12874 12877 12929* 12966* arg2 006626 automatic fixed bin(18,0) dcl 12734 in procedure "rhs_fld" set ref 12743* 12744 12746* 12758 12761 12810* 12823* arg2_is_const 006634 automatic bit(1) initial packed unaligned dcl 12735 in procedure "rhs_fld" set ref 12735* 12760* 12778 12814 arg2_is_const 006656 automatic bit(1) initial packed unaligned dcl 12844 in procedure "lhs_fld" set ref 12844* 12876* 12891 12943 arg3 006650 automatic fixed bin(18,0) dcl 12843 in procedure "lhs_fld" set ref 12859* 12860* 12862* 12899* 12917* 12918* 12920* 12932* 12933* 12940* 12951* 12952* 12958* 12969* 12970* 12977* arg3 006627 automatic fixed bin(18,0) dcl 12734 in procedure "rhs_fld" set ref 12749* 12750* 12752* 12784* 12804* arg4 006651 automatic fixed bin(18,0) dcl 12843 set ref 12865* 12866* 12898* 12903 12905 12910* 12935* 12954* 12973* arg_count 002543 automatic fixed bin(17,0) level 3 packed packed unaligned dcl 2829 set ref 4326* arg_desc based structure level 1 dcl 1-130 set ref 11694 11694 arg_desc_node 000722 constant fixed bin(4,0) initial dcl 4-87 set ref 11694* arg_list 002543 automatic structure level 1 dcl 2829 set ref 4334 4334 arg_no parameter fixed bin(18,0) dcl 11458 ref 11445 11481 arg_ptr constant fixed bin(18,0) initial dcl 2599 ref 7518 args parameter fixed bin(18,0) dcl 5323 ref 5316 5325 array 1(04) based bit(1) array level 4 packed packed unaligned dcl 1-130 set ref 11704* 11753 11756 11816* array_info 1 000117 automatic structure array level 2 in structure "descriptor" dcl 13173 in procedure "make_symbol_descriptor" array_info 1 006754 automatic structure array level 2 in structure "descriptor" dcl 13322 in procedure "make_entry_descriptor" array_ref based structure level 1 dcl 1-155 set ref 2923 2923 array_ref_node 000754 constant fixed bin(4,0) initial dcl 4-87 set ref 2923* 3432 5992 6118 6154 6460 6479 6561 6620 6882 6993 7078 7200 7975 8966 10213 10234 11383 11709 11756 11821 27-224 13141 array_ref_type constant fixed bin(4,0) initial dcl 4-120 ref 2925 array_size 3 based fixed bin(24,0) level 2 in structure "dimension" dcl 1-383 in procedure "fort_optimizing_cg" set ref 2368* 2370 2396* 3953 3955 10712 array_size 005436 automatic fixed bin(18,0) dcl 10687 in procedure "get_param_array_size" set ref 10712* 10740* 10828* 10857* 10885* 10890* 10902* 10907* 10919* array_sym parameter fixed bin(18,0) dcl 8915 in procedure "save_eaq_temps" ref 8908 8921 8921 8966 array_sym parameter fixed bin(18,0) dcl 8899 in procedure "use_eaq" ref 8893 8903 asp 004442 automatic pointer dcl 8919 set ref 8921* 8923* 8966 8966 8966* 8966 8966 asq 000526 constant fixed bin(18,0) initial dcl 25-16 set ref 4155 10869* assembly_list 000251 automatic bit(1) dcl 505 set ref 675* 676 1946 2158 3753 3762 4127 4143 4156 4166 4181 4196 4270 4301 4355 4939 4966 5992 6154 6460 7120 14271 assign_op constant fixed bin(18,0) initial dcl 4-197 ref 12506 assigns_constant_to_symbol 0(09) based bit(1) level 2 packed packed unaligned dcl 2-144 set ref 12576* assumed_size 0(28) based bit(1) level 2 packed packed unaligned dcl 1-383 ref 2424 10736 10883 10919 10958 11678 13265 13422 attributes 10 based structure level 2 dcl 1-844 auto 0(18) based bit(1) level 3 packed packed unaligned dcl 21-23 set ref 2246* auto_template 000332 automatic fixed bin(18,0) dcl 554 set ref 665* 2919 13517* auto_zero 11(29) based bit(1) level 3 packed packed unaligned dcl 1-753 ref 845 automatic 0(33) based bit(1) level 4 in structure "header" packed packed unaligned dcl 1-436 in procedure "fort_optimizing_cg" ref 1227 2243 2246 2261 automatic 11 based bit(1) level 4 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 1646* 1677* 2455* 13290* avail_pregs 000670 automatic fixed bin(4,0) dcl 2533 set ref 2860* 12020 12025 12136* avail_regs parameter fixed bin(4,0) dcl 12158 ref 12155 12165 avail_xregs 000671 automatic fixed bin(4,0) dcl 2534 set ref 2861* 12018 12036 12046 12132* 12244 avoid_pr 25(15) based bit(1) array level 3 packed packed unaligned dcl 2-100 set ref 4733 4733 4733 4739 4751 5848* 6633* 6730* 11932* 11932 11932 b1 000732 automatic bit(1) dcl 2547 set ref 3052* 3056* 3062 3383* 3409* 3416* 3418* 3427* 3430* 3432* 3435* 3437* 3439* 3456* 3458* 3461* 3466 3530* 3536* 3542* 3548* 3555* 3561* 3567* 3568* 3576* 3581* 3587* 3592* 3597* 3607* 3615* 3640* 3644* 3648* 3652* 3656* 3660* 3663 4037* 4040* 4043* 4045* 4046* 4284* 4295* 4298 4304* 4307* 4400* 4410 4427 4673* 4710 4847* 4849 4889* 4899* 4904* 4909* 4915* 4917* 4926* 4928* 4933* 5075* b18 007236 automatic bit(18) dcl 14196 set ref 14205* 14220 b2 000733 automatic bit(1) dcl 2547 set ref 3371* 3375* 3387* 3391* 3413* 3421* 3443* 3447* 3517* 3521* 3533* 3539* 3545* 3551* 3558* 3564* 3573* 3579* 3584* 3590* 3595* 3600* 3604* 3622* 3626* 3663 4034* 4280* 4887* 4896* 4902* 4907* 4913* 4920* 4931* 5073* back 1 based pointer level 2 in structure "flow_unit" packed packed unaligned dcl 2-46 in procedure "fort_optimizing_cg" ref 11911 11916 11918 back 1(18) based fixed bin(18,0) level 2 in structure "operator" packed packed unsigned unaligned dcl 2-144 in procedure "fort_optimizing_cg" set ref 12530 12540 12584* 12586* 27-166 27-167* 27-167 27-172* back 2(18) based bit(18) level 2 in structure "opt_statement" packed packed unaligned dcl 2-176 in procedure "fort_optimizing_cg" ref 27-143 back_target 11 based pointer level 2 packed packed unaligned dcl 2-100 ref 12201 12352 12357 12464 13015 backp 006504 automatic pointer dcl 27-158 set ref 27-166* 27-168 backward 0(18) based bit(18) level 2 packed packed unaligned dcl 8-12 set ref 14211* 14213* base 004134 automatic bit(3) level 2 in structure "inst_address" packed packed unaligned dcl 7185 in procedure "base_man_load_pr" set ref 7244* base parameter bit(3) dcl 7470 in procedure "base_man_load_large_base_no_flush" ref 7462 7476 7481 base 1 based bit(3) level 3 in structure "header" packed packed unaligned dcl 1-436 in procedure "fort_optimizing_cg" set ref 1175* 1185* 1227* 1230* 1353* 1356* base 000104 automatic bit(3) level 2 in structure "inst_address" packed packed unaligned dcl 7376 in procedure "base_man_load_large_base" set ref 7445* base 007022 automatic pointer dcl 13458 in procedure "initialize_static" set ref 13470* 13471 13479* 13481* 13482 13490* 13492* 13493 13508* 13509 base 000101 automatic bit(3) level 2 in structure "inst_address" packed packed unaligned dcl 6778 in procedure "c_a" set ref 6788* 6792* 6796* 6801* 6813* 6813 base 001472 automatic bit(3) level 2 in structure "inst_address" packed packed unaligned dcl 2685 in procedure "interpreter" set ref 4146* 4152* base 004171 automatic bit(3) dcl 7724 in procedure "base_man_dispatch" set ref 7732* 7734* 7735* 7735* 7738* 7741* 7744* 7746 base 000123 automatic bit(3) level 2 in structure "inst_address" packed packed unaligned dcl 7586 in procedure "base_man_store_temp" set ref 7626* 7642* 7654* base 007032 automatic pointer dcl 13534 in procedure "initialize" set ref 13537* 13545* 13548* base 000110 automatic bit(3) level 2 in structure "inst_address" packed packed unaligned dcl 7473 in procedure "base_man_load_large_base_no_flush" set ref 7476* base 1 based bit(3) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 1447* 1457* 1513* 1539* 1585* 1588* 1629* 1648* 1679* 2944* 6681* 6683* base 1 based bit(3) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "fort_optimizing_cg" set ref 4307 4307 6557* 6600* 6657* 6703* 6740* 6743* 6904 7226 9567* 11631 base 1 based bit(3) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "fort_optimizing_cg" set ref 5509* 5846* 6648* 11333 base 1 based bit(3) level 3 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "fort_optimizing_cg" set ref 2928* base 000633 automatic fixed bin(18,0) dcl 2507 in procedure "interpreter" set ref 2986* 3147* 3240* 3246 3247 3249 3251 3259* 4008 4091 4246 4282 4295 4324 4337 4340 4345 4379 4551 4551 4551 4560 4560 4560 4678 4680 4695 4696 4703 4705 4706 4714 4718 4765 4765 4769 4769 4773 4777 4777 4781 4781 4796 4892 5023 5048 5176* 5192 5277* 11224 11267 11346 11668 11669 11677 11678 11678 11699 11722 11728 11768 11768 base 4 based fixed bin(18,0) level 2 in structure "proc_frame" dcl 2718 in procedure "interpreter" set ref 3981* 5176 5277* base parameter bit(3) dcl 7371 in procedure "base_man_load_large_base" ref 7365 7380 7445 base_man_args 001500 automatic structure level 1 unaligned dcl 2692 base_regs 112 based structure array level 3 in structure "machine_state" dcl 1-620 in procedure "fort_optimizing_cg" base_regs 112 based structure array level 3 in structure "loop_state" dcl 9806 in procedure "leave_loop" base_regs 112 parameter structure array level 3 in structure "existing_state" dcl 9514 in procedure "merge_state" base_regs 112 004574 automatic structure array level 3 in structure "new_state" dcl 9514 in procedure "merge_state" base_regs 112 001511 automatic structure array level 3 in structure "current_ms" dcl 2714 in procedure "interpreter" set ref 4265* 4353* 6981* 6999* 7026* 7039* 7440* 7515* 7557* 7637* 9660 9660 9904* base_regs 112 parameter structure array level 3 in structure "a_new_state" dcl 9514 in procedure "merge_state" base_regs 112 parameter structure array level 3 in structure "affected_ms" dcl 10301 in procedure "drop_all_ms_ref_counts" base_regs 112 based structure array level 3 in structure "loop_state" dcl 9839 in procedure "enter_loop" base_regs 112 based structure array level 3 in structure "loop_state" dcl 2716 in procedure "interpreter" set ref 9904 based_double based structure level 1 dcl 9267 based_dp based float bin(63) level 2 packed packed unaligned dcl 9267 ref 9286 based_integer based fixed bin(35,0) dcl 9265 in procedure "check_negative" ref 9279 based_integer based fixed bin(35,0) dcl 2683 in procedure "interpreter" ref 12761 12773 12877 12886 based_real based float bin(27) dcl 9266 ref 9282 bases 000624 constant bit(3) initial array dcl 593 ref 923 923 1175 1175 1185 1185 1227 1227 1230 1230 1353 1353 1356 1356 1447 1447 1457 1457 1513 1513 1539 1539 1585 1585 1588 1588 1629 1629 1648 1648 1679 1679 2928 2928 2944 2944 4307 4307 4307 4307 5509 5509 5846 6733 6733 6734 6734 6788 6788 6792 6792 6796 6796 6801 6801 6967 6979 7059 7226 7244 7380 7380 7395 7458 7481 7481 7488 7511 7529 7553 7571 7626 7642 7642 7654 7654 7732 7732 7734 7734 9567 begin_external_list 000205 automatic fixed bin(18,0) dcl 491 set ref 688* 1770 1770 1803 1810 13920 begin_forward_refs 000207 automatic fixed bin(18,0) dcl 493 set ref 708* 727 734 786 14076 begin_links 000175 automatic fixed bin(18,0) dcl 488 set ref 819 1725* 13881 13883 bias constant fixed bin(19,0) initial dcl 4-56 ref 1453 1474 1654 1686 3053 3090 3106 3112 3117 3175 3247 3355 3631 3634 3674 3706 3714 3729 3730 3814 3931 3932 3932 3935 3940 4029 4102 4149 4151 4211 4212 4235 4259 4283 4325 4341 4547 4551 4560 4601 4614 4641 4883 5048 5081 5093 5138 5198 5334 5334 5497 6108 6515 9249 9270 10604 10739 10809 10822 10866 10891 10934 10994 11022 11048 11048 11048 11079 11079 11079 11277 11286 11376 11389 11578 11668 12790 12797 12798 12808 12818 12912 12938 12956 13030 13131 13138 13145 13152 13212 13370 14135 bif constant fixed bin(4,0) initial dcl 4-120 ref 1410 11568 13202 13360 bin builtin function dcl 645 ref 637 binary builtin function dcl 645 in procedure "code_generator" ref 2424 5995 7252 7252 7842 8109 14038 binary builtin function dcl 12-19 in procedure "create_constant" ref 12-57 bit builtin function dcl 6397 in procedure "emit_eis" ref 6455 bit builtin function dcl 645 in procedure "code_generator" ref 781 781 813 814 815 816 817 818 819 820 821 829 4029 4084 6857 8021 8058 8109 8129 8202 8203 8227 11633 11634 13880 13881 13882 13883 14035 14042 14083 14098 14104 14143 14167 14207 14223 14264 14264 bit3 005141 automatic bit(3) dcl 9957 in procedure "refresh_regs" set ref 9983* bit3 000736 automatic bit(3) dcl 2548 in procedure "interpreter" set ref 4137* 4140 4146 4158 4165* 4168 4736* 4737 4747* 4748 bit6 004453 automatic bit(6) dcl 8947 in procedure "save" set ref 8990* bit6 005140 automatic bit(6) dcl 9956 in procedure "refresh_regs" set ref 9971* bit6 000117 automatic bit(6) dcl 9057 in procedure "save_logical_temps" set ref 9080* bit6 000737 automatic bit(6) dcl 2549 in procedure "interpreter" set ref 4681* 4682 bit_image based bit(72) dcl 2710 set ref 3083* 3083* bit_offset 3(21) 002543 automatic bit(6) array level 3 packed packed unaligned dcl 2829 set ref 11634* bit_type 000117 automatic structure level 3 in structure "descriptor" packed packed unaligned dcl 13173 in procedure "make_symbol_descriptor" bit_type 006754 automatic structure level 3 in structure "descriptor" packed packed unaligned dcl 13322 in procedure "make_entry_descriptor" bit_type 005661 automatic structure level 3 in structure "descriptor" packed packed unaligned dcl 11546 in procedure "make_descriptor" bits 112 based structure array level 4 in structure "loop_state" packed packed unaligned dcl 9839 in procedure "enter_loop" bits 41 based structure array level 4 in structure "machine_state" packed packed unaligned dcl 1-620 in procedure "fort_optimizing_cg" bits 0(25) based structure level 2 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" bits 112 parameter structure array level 4 in structure "existing_state" packed packed unaligned dcl 9514 in procedure "merge_state" bits 0(25) based structure level 2 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "fort_optimizing_cg" bits 41 001511 automatic structure array level 4 in structure "current_ms" packed packed unaligned dcl 2714 in procedure "interpreter" bits 112 based structure array level 4 in structure "machine_state" packed packed unaligned dcl 1-620 in procedure "fort_optimizing_cg" bits 0(25) based structure level 2 in structure "header" packed packed unaligned dcl 1-436 in procedure "fort_optimizing_cg" bits 0(25) based structure level 2 in structure "node" packed packed unaligned dcl 1-63 in procedure "fort_optimizing_cg" bits 0(25) based structure level 2 in structure "label" packed packed unaligned dcl 1-530 in procedure "fort_optimizing_cg" bits 2 based structure level 2 in structure "range" packed packed unaligned dcl 2-243 in procedure "fort_optimizing_cg" bits based bit dcl 2702 in procedure "interpreter" set ref 4691 4691 4696 8326 8410 8529 10126 10177 12317 12473 12473 12473 12522 12547 12547* 12623 bits 41 based structure array level 4 in structure "loop_state" packed packed unaligned dcl 9839 in procedure "enter_loop" bits 25 based structure level 2 in structure "loop" packed packed unaligned dcl 2-100 in procedure "fort_optimizing_cg" bits parameter structure array level 2 in structure "regs" packed packed unaligned dcl 7882 in procedure "get_free_reg" bits 4 based structure level 2 in structure "opt_statement" packed packed unaligned dcl 2-176 in procedure "fort_optimizing_cg" bits 0(25) based structure level 2 in structure "char_constant" packed packed unaligned dcl 1-316 in procedure "fort_optimizing_cg" bits 112 001511 automatic structure array level 4 in structure "current_ms" packed packed unaligned dcl 2714 in procedure "interpreter" bits 0(25) based structure level 2 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "fort_optimizing_cg" set ref 5504* bits 0(18) based bit(10) array level 2 in structure "macro_bits_inst" packed packed unaligned dcl 2780 in procedure "interpreter" ref 3381 3383 3400 3409 bits 0(25) based structure level 2 in structure "constant" packed packed unaligned dcl 1-256 in procedure "fort_optimizing_cg" bits 41 parameter structure array level 4 in structure "existing_state" packed packed unaligned dcl 9514 in procedure "merge_state" bits_per_char constant fixed bin(9,0) initial dcl 4-68 ref 10934 11634 blank_common_name 000644 constant char(8) initial dcl 4-79 ref 1816 2022 block_name 10 based char level 2 in structure "header" dcl 1-436 in procedure "fort_optimizing_cg" set ref 1811 1811 1816 1995 1995 2022 2256 13937 13937* 13940* 13942* 14135* block_name 3(18) based char level 2 in structure "create_entry" packed packed unaligned dcl 21-23 in procedure "code_generator" set ref 2256* block_size parameter fixed bin(18,0) dcl 5376 ref 5371 5378 block_type 007126 automatic bit(18) dcl 13958 set ref 13974* 13983* 13985* 14001* 14024 boffset 000116 automatic fixed bin(35,0) dcl 13715 set ref 13752* 13754* 13754 13803 13808 13813 13818 bool builtin function dcl 645 in procedure "code_generator" ref 7841 7841 bool builtin function dcl 12-20 in procedure "create_constant" ref 12-54 brother 3 based pointer level 2 packed packed unaligned dcl 2-100 ref 10052 10058 12143 12149 12257 12263 bsize 000124 automatic fixed bin(18,0) dcl 13717 set ref 13801* 13803 13803 13803 13806* 13808 13808 13808 13811* 13813 13816* 13818 13831 13855 bt 006252 automatic pointer dcl 12459 in procedure "propagate_and_eliminate_assignment" set ref 12464* 12473 12480 12482 12522 12540 12540 12547 12547 bt parameter pointer dcl 27-132 in procedure "derive_insert_for_bt" ref 27-130 27-137 27-143 27-144 27-147 27-149 bt 006204 automatic pointer dcl 12307 in procedure "check_comparisons_and_increments" set ref 12357* 12375 12375 12387 12409 bt 006146 automatic pointer dcl 12194 in procedure "allocate" set ref 12201* 12226 12226 bt_statement 006466 automatic fixed bin(18,0) dcl 27-134 set ref 27-137* 27-138 27-147 btst 006472 automatic pointer dcl 27-135 set ref 27-138* 27-139 27-143 27-144 27-148 builtin 10(32) based bit(1) level 4 packed packed unaligned dcl 1-844 set ref 1408 builtins 000254 automatic fixed bin(18,0) array dcl 508 set ref 666* 800 1623* 1624 1634* 1642* 1643 1660* 1661 1667* 1667* 2872* 2873* 2874* 2875* 2876* 2881 2895 2905 2907* 2908 2917 2921 2923* 2924 2931 2934 2937 2939* 2940 2947 2949* 2950 3122 4773* 11481 11482 13027 13027 busy_on_exit 22 based pointer level 2 in structure "flow_unit" packed packed unaligned dcl 2-46 in procedure "fort_optimizing_cg" ref 4696 busy_on_exit 22 based pointer level 2 in structure "loop" packed packed unaligned dcl 2-100 in procedure "fort_optimizing_cg" ref 4691 8410 8529 12473 bvalue 005376 automatic bit(72) dcl 10519 set ref 10521* 10522* by_compiler 0(35) based bit(1) level 3 packed packed unaligned dcl 1-844 set ref 1626* 1645* 1676* 2455* 2942* 2953* 13287* byte builtin function dcl 645 ref 4824 c 006262 automatic fixed bin(18,0) dcl 12460 in procedure "propagate_and_eliminate_assignment" set ref 12471* 12473 12473 12473 12547 12547 c 006520 automatic pointer dcl 27-184 in procedure "put_in_loop_end" set ref 27-191* 27-192 27-193 27-194 27-203* c parameter fixed bin(18,0) dcl 6776 in procedure "c_a" ref 6771 6780 6813 c 000162 automatic pointer dcl 486 in procedure "code_generator" set ref 750* 751 752 867* 868 868 868 871 872 874 876 891* 892 892 892 895 900 901 902 906 908 c 006362 automatic pointer dcl 12651 in procedure "process_loop_end_lists" set ref 12663* 12663* 12665 12666* 12667 c 004247 automatic fixed bin(18,0) dcl 8194 in procedure "xr_man_add_const" set ref 8200* 8202 c 006170 automatic pointer dcl 12277 in procedure "alloc_inner" set ref 12281* 12281* 12282* 12285 12288* 12289 12290 12291 c 004224 automatic fixed bin(18,0) dcl 8102 in procedure "xr_man_load_const" set ref 8104* 8106* 8118* 8118* 8123 c 006124 automatic pointer dcl 12162 in procedure "ok" set ref 12168* 12168* 12169* 12171 c 004235 automatic fixed bin(18,0) dcl 8166 in procedure "const_in_xr" set ref 8168* 8174 c 006206 automatic pointer dcl 12307 in procedure "check_comparisons_and_increments" set ref 12317* 12317* 12321* 12444 c 006150 automatic pointer dcl 12194 in procedure "allocate" set ref 12206* 12207 12212 12213 12221 12222 c_mult_offset 005442 automatic fixed bin(18,0) dcl 10687 set ref 10761* 10763* 10845 10845 10931 10931 c_multiplier 005440 automatic fixed bin(18,0) dcl 10687 set ref 10753* 10757* 10780 10781* 10781 10790 10822 10824 10824 c_off parameter fixed bin(18,0) dcl 6007 ref 6001 6015 c_virtual_origin 005437 automatic fixed bin(18,0) dcl 10687 set ref 10749* 10780* 10780 10790 10803 10809 10811 10811 call_op constant fixed bin(18,0) initial dcl 4-197 ref 12491 case 000123 automatic fixed bin(18,0) dcl 13717 in procedure "list_initialize_symbol" set ref 13761* 13765* 13767* 13799 13833 case 007057 automatic fixed bin(18,0) dcl 13596 in procedure "initialize_symbol" set ref 13639* 13643* 13645* 13678 cat_offset_temp 001474 automatic fixed bin(18,0) dcl 2688 set ref 11247* 11292 11299* 11300 11302 11306* 11313* 11314 11317* 11318 11348 11348 11348 cat_result parameter fixed bin(18,0) dcl 11417 ref 11410 11421 cdt 000714 automatic fixed bin(4,0) dcl 2542 set ref 3100* 3102 ceil builtin function dcl 1798 ref 1820 1832 cg_globals based structure level 1 dcl 52 cg_struc_ptr 000102 automatic pointer dcl 36 set ref 66* 670 705 738 743 748 803* 3962 3969 4334 10487 10488 10490 10499 10500 10507 10508 10509 chain based structure level 1 dcl 2-27 in procedure "fort_optimizing_cg" set ref 27-34 27-34 27-34 27-37 27-38 27-38 chain 2 based pointer level 2 in structure "entry" dcl 1982 in procedure "create_storage_entry" set ref 2034 2035 2041* 2041 2042* 2057 2061 2062 2064 2073* 2073 2076* 2128 2133 2164 2210 2224* chain parameter fixed bin(18,0) dcl 5756 in procedure "thread_temp" ref 5750 5763 5764 chain_head 000106 automatic pointer dcl 1972 set ref 2015* 2034 2049* 2056 2099* 2099* 2103 2119 2121 2122 2122 2125 2125 2128 2168* 2168* 2169 2206* 2208 char builtin function dcl 12-21 in procedure "create_constant" ref 12-45 12-45 char builtin function dcl 13-17 in procedure "create_node" ref 13-29 13-29 char builtin function dcl 645 in procedure "code_generator" ref 1718 1718 1772 1772 1841 1841 1844 1844 1876 1876 1882 1882 2022 2022 2343 2343 5301 5301 6329 6329 27-54 27-54 27-122 27-122 char1 000721 automatic char(1) packed unaligned dcl 2544 set ref 4824* 4825* 4825* char77_target based char array packed unaligned dcl 13736 in procedure "list_initialize_symbol" set ref 13848* char77_target based char array packed unaligned dcl 13614 in procedure "initialize_symbol" set ref 13692* char_constant based structure level 1 dcl 1-316 set ref 2907 2907 char_constant_length 000125 automatic fixed bin(18,0) unsigned dcl 1-378 set ref 2903* 2907 2907 char_constant_node 000751 constant fixed bin(4,0) initial dcl 4-87 set ref 2907* 3848 4043 4833 6250 11735 12706 13131 char_image based char dcl 530 set ref 902* char_length parameter fixed bin(18,0) dcl 5363 ref 5358 5366 char_mode constant fixed bin(4,0) initial dcl 4-106 ref 12-43 1494 2910 2926 4040 5365 5392 5570 5591 5808 6593 8721 10601 11573 12703 13128 13207 13286 13365 char_num 1(18) based fixed bin(2,0) level 3 in structure "node" packed packed unsigned unaligned dcl 1-63 in procedure "fort_optimizing_cg" set ref 3437 7216 7217* 7285* 11634 char_num 1(18) based fixed bin(2,0) level 3 in structure "symbol" packed packed unsigned unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 1899* 3430 10634 13631 13754 char_num 1(18) based fixed bin(2,0) level 3 in structure "array_ref" packed packed unsigned unaligned dcl 1-155 in procedure "fort_optimizing_cg" set ref 3435 10641* 10642 char_num 1(18) based fixed bin(2,0) level 3 in structure "temporary" packed packed unsigned unaligned dcl 1-1005 in procedure "fort_optimizing_cg" set ref 11277 11280* 11281 char_num_hold 004136 automatic fixed bin(2,0) dcl 7187 set ref 7216* 7246 7252 7261 7271 7285 char_overlay based char(1) array packed unaligned dcl 13616 set ref 13632 char_size 10 based fixed bin(20,0) level 4 packed packed unsigned unaligned dcl 1-844 set ref 3940 4040 12703 13138 13291* 13638 13642 13760 13764 char_star_ndims 000114 automatic fixed bin(18,0) dcl 13170 in procedure "make_symbol_descriptor" set ref 13193* 13232* 13277 13277 13291 13292 char_star_ndims 006751 automatic fixed bin(18,0) dcl 13319 in procedure "make_entry_descriptor" set ref 13341* 13389* 13434 13434 char_target based char array dcl 13734 in procedure "list_initialize_symbol" set ref 13843* char_target based char array dcl 13612 in procedure "initialize_symbol" set ref 13688* char_temp 001476 automatic char(8) packed unaligned dcl 2690 set ref 4604* 4605 4605 4617* 4618 4618 char_units constant fixed bin(3,0) initial dcl 4-136 ref 1896 3425 5395 6593 7207 7226 7238 8721 10634 10639 10761 10925 11575 13209 13367 13629 13635 13754 13757 character 0(32) based bit(1) level 4 in structure "header" packed packed unaligned dcl 1-436 in procedure "fort_optimizing_cg" ref 14129 character 10(25) based bit(1) level 5 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 13288* 13635 13757 character_operand 1 based fixed bin(18,0) level 2 unsigned dcl 1-605 ref 750 chars_per_dw constant fixed bin(9,0) initial dcl 4-68 ref 895 4611 4614 4614 4617 4618 4618 chars_per_word 000747 constant fixed bin(9,0) initial dcl 4-68 ref 900 900 1898 1899 2913 2932 4598 4601 4601 4604 4605 4605 5367 5367 10634 10641 10642 10644 11277 11278 11280 11281 11283 11400 13186 13335 14102 14102 14129 14129 check_multiply 11(31) based bit(1) level 3 packed packed unaligned dcl 1-753 ref 4909 class 1(33) based bit(3) level 2 in structure "definition" packed packed unaligned dcl 8-12 in procedure "fort_optimizing_cg" set ref 14223* class parameter fixed bin(3,0) dcl 14191 in procedure "generate_definition" ref 14188 14223 14225 14229 14234 cleanup builtin function dcl 645 ref 1112 cleanup_body_address 000160 automatic fixed bin(18,0) unsigned dcl 483 set ref 1673* 1674 1684* 1689* 4937 clength 000100 automatic fixed bin(18,0) dcl 5351 set ref 5366* 5367 5394 clp 000114 automatic pointer dcl 1078 set ref 1674* 1675 1676 1677 1677 1677 1677 1677 1679 1680 1683* cm 000216 automatic fixed bin(18,0) dcl 2358 in procedure "get_array_size" set ref 2375* 2377 2378* 2378 cm 006745 automatic fixed bin(18,0) dcl 13319 in procedure "make_entry_descriptor" set ref 13392* 13394* 13398 13405* 13405 cm 000107 automatic fixed bin(18,0) dcl 13170 in procedure "make_symbol_descriptor" set ref 13235* 13237* 13241 13248* 13248 cmpc constant bit(10) initial dcl 6388 ref 6479 cmpx0 constant fixed bin(18,0) initial dcl 25-16 ref 8482 9435 cmpx_image based complex float bin(27) dcl 2709 set ref 2888* cmpx_mode 000747 constant fixed bin(4,0) initial dcl 4-106 set ref 1492 2889* 3481 3490 code 001500 automatic fixed bin(18,0) level 2 in structure "base_man_args" dcl 2692 in procedure "interpreter" set ref 4729* 4736* 4747* 4760* code 000103 automatic fixed bin(18,0) dcl 7375 in procedure "base_man_load_large_base" set ref 7380* 7382* 7384* 7392 7406* 7450 7453 code parameter fixed bin(18,0) dcl 7797 in procedure "add_global_ptr" ref 7792 7801 code 000110 automatic fixed bin(18,0) dcl 7824 in procedure "find_ptr" set ref 7835* 7841 7850 7862 code parameter fixed bin(18,0) dcl 6938 in procedure "base_man_load_any_pr" ref 6935 6949 code 0(09) based fixed bin(9,0) level 2 in structure "pointer" packed packed unsigned unaligned dcl 1-672 in procedure "fort_optimizing_cg" set ref 4729 7850 7862* code parameter fixed bin(18,0) dcl 6776 in procedure "c_a" ref 6771 6782 code 005156 automatic fixed bin(18,0) dcl 10015 in procedure "assign_register" set ref 10029* 10079 10086 10089 code parameter fixed bin(18,0) dcl 6827 in procedure "c_a_18" ref 6822 6841 code 000100 automatic fixed bin(18,0) dcl 7667 in procedure "find_global_base" set ref 7675* 7680 code 004166 automatic fixed bin(18,0) dcl 7720 in procedure "base_man_dispatch" set ref 7726* 7730 7730 7732 7738 7741 7744* code_emitted 005434 automatic bit(1) dcl 10683 set ref 10733* 10747* 10776 10784* 10835 11034* 11045 11075 common 0(20) based bit(1) level 3 packed packed unaligned dcl 21-23 set ref 2187 2248* common_chain 2 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 ref 1291 common_length 000122 automatic fixed bin(35,0) dcl 2093 set ref 2103* 2129 common_link 3 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 21-23 set ref 2122* 2187* 2187 compare_inst 000506 constant fixed bin(18,0) initial array dcl 25-16 ref 3881 4425 9430 computed 30 based pointer level 2 packed packed unaligned dcl 2-100 ref 8334 12628 12632 computed_virtual_origin 001415 automatic fixed bin(18,0) array dcl 2555 set ref 11113 11121 11124* con 000320 automatic fixed bin(18,0) dcl 534 set ref 866* 866* 867* 890* 890* 891* const 006747 automatic fixed bin(18,0) dcl 13319 in procedure "make_entry_descriptor" set ref 13432* 13434* 13438 13442 13446 const 000106 automatic pointer dcl 6008 in procedure "emit_c_a_const" set ref 6015* 6017 6019 6021* const 000112 automatic fixed bin(18,0) dcl 13170 in procedure "make_symbol_descriptor" set ref 13275* 13277* 13293 13301 const 005655 automatic fixed bin(18,0) dcl 11543 in procedure "make_descriptor" set ref 11586* 11599* 11609 constant based structure level 1 dcl 1-256 set ref 12-74 12-74 constant_address 005416 automatic structure level 1 dcl 10540 constant_count 77 based fixed bin(17,0) array level 3 dcl 47 set ref 12-87* 12-87 constant_info 77 based structure array level 2 dcl 47 constant_node 000752 constant fixed bin(4,0) initial dcl 4-87 set ref 12-74* 3848 4576 4627 4822 6248 8470 8511 9252 12509 12637 12758 12770 12874 12883 12903 constant_type constant fixed bin(4,0) initial dcl 4-120 ref 12-82 2909 10584 11424 constant_vo 000223 automatic bit(1) dcl 2360 set ref 2407* 2408 2409* 2411 conv_round 2500 based entry variable array level 2 dcl 47 ref 3102 coord parameter fixed bin(18,0) dcl 10161 ref 10158 10174 coordinate 14(25) based fixed bin(17,0) level 2 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 4690 8326 8326 8410 8529 10126 10126 12317 12317 12471 12522 12623 12623 coordinate 0(18) based fixed bin(18,0) level 2 in structure "operator" packed packed unsigned unaligned dcl 2-144 in procedure "fort_optimizing_cg" ref 8334 8334 12632 12632 copy builtin function dcl 12845 in procedure "lhs_fld" ref 12905 copy builtin function dcl 645 in procedure "code_generator" ref 2124 2241 2243 2273 count based bit(9) level 2 in structure "acc" packed packed unaligned dcl 14057 in procedure "name_assign" set ref 14078 14098* count 000104 automatic fixed bin(18,0) dcl 5617 in procedure "free_temp" set ref 5629* 5631* 5632 count 000102 automatic fixed bin(18,0) dcl 7887 in procedure "get_free_reg" set ref 7905* 7907* 7909 7911 7916 count 000124 automatic fixed bin(18,0) dcl 7944 in procedure "get_usage_count" set ref 7958* 7967* 7967 7972 count 1(18) based fixed bin(18,0) level 2 in structure "pointer" packed packed unsigned unaligned dcl 1-672 in procedure "fort_optimizing_cg" set ref 7803 7815* 7815 11989* 12102 12102 count_is_zero 005310 automatic bit(1) dcl 10302 set ref 10307* 10309 10327* 10329 10338* 10340 count_type constant fixed bin(4,0) initial dcl 4-120 ref 3407 create_char_constant 1524 based entry variable level 2 dcl 47 ref 4605 4618 4825 4825 13277 13434 create_constant_block 34 based entry variable level 2 dcl 52 ref 4334 create_entry based structure level 1 unaligned dcl 21-23 set ref 1959 2166 create_init_entry based structure level 1 unaligned dcl 21-61 set ref 13853 cs parameter pointer dcl 842 in procedure "get_subr_options" ref 836 844 845 846 847 848 cs 000614 automatic pointer dcl 1021 in procedure "restore_after_analysis" set ref 1034* 1035 1039 cs 000104 automatic pointer dcl 13169 in procedure "make_symbol_descriptor" set ref 13297* 13298 13299 cs 000106 automatic pointer dcl 1078 in procedure "assign_storage" set ref 1133* 1134* 1138 1142 1150 1154 1204 1204 1206 1207 1219 1276 1276 1278 1279 1291 1306 1306 1308 1309 1321 1339 1339 1339 1343 1344 1344 1345 1345 1369 1369 1371 1372 1380 1391 1578 1579 1579 1604 1604 1606 1607 1614 1728* 1729* 1733 1739 1759 1772 2296* 2297* 2300 2300 2302 2322 2326 2341 2343 2396* 2414* 2430* cs parameter pointer dcl 2473 in procedure "create_rel_constant" ref 2468 2487 2489 2489 2491 2492 cs 000642 automatic pointer dcl 2513 in procedure "interpreter" set ref 3073* 3073* 3435 3581 3592 4020 4204 4206 4889 4904 4909 5075 5395 7518 7520 7560 7562 11942 11970* 12993* 12994* 12996 12997 12998 12999 13006 13021 13023 13026 13030 cs parameter pointer dcl 2450 in procedure "create_automatic_integer" ref 2443 2459 2460 csize 007060 automatic fixed bin(18,0) dcl 13596 in procedure "initialize_symbol" set ref 13638* 13642* 13688 13688 13688 13692 13692 13692 csize 004051 automatic fixed bin(18,0) dcl 6505 in procedure "get_eis_length" set ref 6514* 6515 6515 6518 6518 6518 6520 6520 csize 005604 automatic fixed bin(18,0) dcl 11365 in procedure "get_cat_alloc_length" set ref 11369* 11370 11376 11385* 11386 11389 csize 005415 automatic fixed bin(18,0) dcl 10538 in procedure "optimized_subscript" set ref 10586* 10587 10593 10603* 10604 10604 10608 csize 005657 automatic fixed bin(18,0) dcl 11543 in procedure "make_descriptor" set ref 11577* 11578 11578 csize 006752 automatic fixed bin(18,0) dcl 13319 in procedure "make_entry_descriptor" set ref 13369* 13370 13370 csize 000115 automatic fixed bin(18,0) dcl 13170 in procedure "make_symbol_descriptor" set ref 13211* 13212 13212 csize parameter fixed bin(18,0) dcl 8192 in procedure "xr_man_add_const" ref 8186 8200 csize 000125 automatic fixed bin(18,0) dcl 13717 in procedure "list_initialize_symbol" set ref 13760* 13764* 13811 13816 13843 13843 13843 13848 13848 13848 csize parameter fixed bin(18,0) dcl 8099 in procedure "xr_man_load_const" ref 8094 8104 csize 005562 automatic fixed bin(18,0) dcl 11263 in procedure "continue_cat" set ref 11270* 11271 11277 11286* 11286 11303* 11304* 11315* 11316* csp 007014 automatic pointer dcl 13456 set ref 13464* 13468 13476 13487 13495 13500* 13502 13520* 13522 13524 13540 cur_frame 000636 automatic pointer dcl 2510 set ref 2979* 2981* 2984* 3144 3154 3163 3263 3287 3350 3353 3353 3355 3355 3355 3357 3357 3361 3365 3365 3366 3366 3972 3973* 3973 3981 3983 5175* 5175 5176 5236 5237 5264 5264* 5264 5266* 5270 5272 5275 5276 5277 5278 5297 5306 5306 5310 cur_lp 006202 automatic pointer dcl 12304 in procedure "check_comparisons_and_increments" set ref 12313* 12317 12317 12352 cur_lp 000650 automatic pointer dcl 2517 in procedure "interpreter" set ref 3554* 4061* 4067 4072* 4074* 4796 5848 6633 6730 7304 7356 8326 8334 8410 8410 8421* 8529 8529 8548 8548 9583* 10126 10418 10418 12018 12020 12025 12027* 12029* 12030 12030 12036 12038* 12040* 12041 12041 12046 12991* cur_lp parameter pointer dcl 11871 in procedure "reset_scan" set ref 11866 11890 11930 11930 11930 11932 11932 11932 11946* 11947 cur_pos 000100 automatic fixed bin(18,0) unsigned dcl 1921 set ref 1948* 1952 2160* 2161 cur_statement parameter fixed bin(18,0) dcl 11871 in procedure "reset_scan" set ref 11866 11951* 11952 cur_statement 67 based fixed bin(18,0) level 2 in structure "shared_globals" dcl 47 in procedure "fort_optimizing_cg" set ref 660* 2868* 4049* 4061* 13072* 13072* 13075* cur_subprogram 71 based fixed bin(18,0) level 2 dcl 47 set ref 1033* 1033* 1034* 1132* 1132* 1133* 1727* 1727* 1728* 2295* 2295* 2296* 2866* 4020* 4021 12993 13297 cur_subr 007012 automatic fixed bin(18,0) dcl 13455 set ref 13463* 13463* 13464* 13499* 13499* 13500* 13519* 13519* 13520* current_def_offset 7 000130 automatic fixed bin(18,0) level 2 dcl 58 set ref 796* current_link_offset 10 000130 automatic fixed bin(18,0) level 2 dcl 58 set ref 797* current_ms 001511 automatic structure level 1 dcl 2714 set ref 2963* 9503* 9697* 9788* 10429* 13108* current_offset 000123 automatic fixed bin(35,0) dcl 2094 set ref 2135* 2137* 2141 2150 2152* current_text_offset 6 000130 automatic fixed bin(18,0) level 2 dcl 58 set ref 795* currentsize builtin function dcl 645 in procedure "code_generator" ref 13853 currentsize builtin function dcl 1926 in procedure "create_storage_entry" ref 1959 2166 d 005426 automatic pointer dcl 10681 in procedure "get_param_array_size" set ref 10706* 10708 10712 10727 10729 10729 10730 10731 10736 10738 10778 10780 10781 10785 10790 10790 10792 10793 10857 10857 10864 10864 10866 10866 10883 10891 10891 10893 10899 10899 10899 10901 10912 10919 10958 10960 10962 10970 10972 10983 10991 10994 10995 10999 11003 11006 11006 11007 11008 11011 11015 11018 11021 11023 d 006742 automatic pointer dcl 13318 in procedure "make_entry_descriptor" set ref 13347* 13350 13350* 13350 13354 13355 13385* 13386 13401 13403 13404 13405 13415 13415 13420 13420 13422 d 000102 automatic pointer dcl 13169 in procedure "make_symbol_descriptor" set ref 13228* 13229 13244 13246 13247 13248 13258 13258 13263 13263 13265 13285* 13286 13287 13288 13289 13290 13291 13292 13293 d 000214 automatic pointer dcl 2357 in procedure "get_array_size" set ref 2364* 2368 2368 2369 2370 2376 2377 2378 2381 2382 2394 2396 2397 2398 2401 2405 2407 2409 2414 2415 2416 2422 2424 2425 2425 2425 2425 2428 2428 2428 2428 2430 2432 d 006055 automatic fixed bin(17,0) dcl 12060 in procedure "sort_globals" set ref 12065* 12067 12068* 12068 12070 12071 12073 12083 d 005514 automatic pointer dcl 11100 in procedure "get_virtual_origin" set ref 11104* 11109 11113 11116 11124 11127 data 2 based structure level 2 dcl 2-234 data_size 000104 automatic fixed bin(17,0) dcl 12-22 set ref 12-47* 12-49 12-87 12-87 12-89 12-89 12-91 12-93 data_type parameter fixed bin(4,0) dcl 12-15 in procedure "create_constant" ref 12-13 12-40 data_type parameter fixed bin(4,0) dcl 5349 in procedure "assign_temp" ref 5344 5353 data_type 1 based fixed bin(4,0) array level 3 in structure "arg_desc" packed packed unsigned unaligned dcl 1-130 in procedure "fort_optimizing_cg" set ref 11700* 11737 11809 11812* 11834* data_type 0(05) based fixed bin(4,0) level 2 in structure "node" packed packed unsigned unaligned dcl 1-63 in procedure "fort_optimizing_cg" ref 12-65 4037 4037 4037 4040 4822 6593 8721 9274 9274 9277 11571 11700 11737 12701 12701 12701 12703 12738 12744 12848 12854 13128 data_type 0(05) based fixed bin(4,0) level 2 in structure "char_constant" packed packed unsigned unaligned dcl 1-316 in procedure "fort_optimizing_cg" set ref 2910* data_type 0(05) based fixed bin(4,0) level 2 in structure "temporary" packed packed unsigned unaligned dcl 1-1005 in procedure "fort_optimizing_cg" set ref 5384* 5570 5572 5591 5808* 12603* data_type 0(18) based fixed bin(9,0) array level 2 in structure "macro_dt_inst" packed packed unaligned dcl 2774 in procedure "interpreter" ref 3037 3078 3101 3316 5327 10488 10508 data_type 0(05) based fixed bin(4,0) level 2 in structure "constant" packed packed unsigned unaligned dcl 1-256 in procedure "fort_optimizing_cg" set ref 12-81* 3100 4576 4576 4630 9252 data_type 0(05) based fixed bin(4,0) level 2 in structure "array_ref" packed packed unsigned unaligned dcl 1-155 in procedure "fort_optimizing_cg" set ref 2926* 10601 data_type 0(05) based fixed bin(4,0) level 2 in structure "symbol" packed packed unsigned unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 1492 1494 1568 2454* 2952* 3378 3471 3473 3498 11812 13205 13286* 13363 13645 13767 data_type_size 000635 constant fixed bin(17,0) initial array dcl 4-115 ref 12-43 12-47 1568 3084 5354 13645 13767 datum 2 based bit level 2 packed packed unaligned dcl 21-61 set ref 13835 13839 13843 13848 debugging 113(16) based structure level 4 in structure "shared_globals" packed packed unaligned dcl 47 in procedure "fort_optimizing_cg" debugging 11(16) based structure level 3 in structure "subprogram" packed packed unaligned dcl 1-753 in procedure "fort_optimizing_cg" decimal builtin function dcl 12-23 ref 12-45 12-45 decl_vers based fixed bin(17,0) level 2 dcl 16-10 set ref 811* decrement_address 004000 automatic bit(1) packed unaligned dcl 6083 set ref 6130* 6135* 6144 6161 def_base 000220 automatic pointer dcl 498 set ref 769* 13891 13905 14019 14090 14132 14144 14208 14215 14269 def_header based structure level 1 dcl 13871 def_offset 1 based bit(18) level 2 packed packed unaligned dcl 15-52 set ref 13880* def_pool 000273 automatic fixed bin(18,0) array dcl 532 set ref 662* 14166 14167 14167 14174* def_pos 000173 automatic fixed bin(18,0) dcl 488 set ref 667* 790 796 815 13895* 14019 14020 14035 14042 14045* 14045 14090 14101 14102* 14102 14132 14132 14140* 14140 14140 14143 14174 14177* 14177 14178* 14178 14180* 14180 14207 14237* 14237 def_ptr 007232 automatic pointer dcl 14195 in procedure "generate_definition" set ref 14208* 14211 14213 14217 14219 14220 14221 14223 14228 14229 def_ptr 007252 automatic pointer dcl 14247 in procedure "gen_entry_defs" set ref 14269* 14274 def_ptr 007130 automatic pointer dcl 13960 in procedure "compile_link" set ref 14019* 14024 14025 14029 14030 14035 def_reloc_base 000232 automatic pointer dcl 499 set ref 770* 794 13892 14020 14209 def_reloc_base_ptr 4 000130 automatic pointer level 2 dcl 58 set ref 794* def_reloc_ptr 007134 automatic pointer dcl 13960 in procedure "compile_link" set ref 14020* 14026 14031 14033 14036 def_reloc_ptr 007234 automatic pointer dcl 14195 in procedure "generate_definition" set ref 14209* 14232 14233 14234 defblock 2(18) based bit(18) level 2 packed packed unaligned dcl 9-3 set ref 13905* definition based structure level 1 dcl 8-12 definition_length 4(18) based bit(18) level 2 packed packed unaligned dcl 16-10 set ref 815* definition_offset 4 based bit(18) level 2 packed packed unaligned dcl 16-10 set ref 814* defrel 000177 automatic fixed bin(18,0) dcl 488 set ref 768* 769 770 790 814 13880 14082 depth 1 based fixed bin(18,0) level 2 dcl 2-100 ref 11890 11890 desc 007246 automatic fixed bin(18,0) dcl 14246 in procedure "gen_entry_defs" set ref 14280* 14281 desc 005654 automatic fixed bin(18,0) dcl 11543 in procedure "make_descriptor" set ref 11593* 11594 11596 11600* 11606 11607 11609* 11611 desc 000710 automatic fixed bin(18,0) dcl 2540 in procedure "interpreter" set ref 4349* 4358* desc 005443 automatic fixed bin(18,0) dcl 10687 in procedure "get_param_array_size" set ref 10696* 10702 10702 10702* 10717 10727 10761 10845 10845* 10848* 10925 10931* 10933* 10935* 10960 10963* 10981 10984* 10992 10992* 11001 11004* 11013 11016* 11019 11019* desc 005642 automatic fixed bin(18,0) dcl 11518 in procedure "copy_array_desc_template" set ref 11521* 11523 11524* desc 000110 automatic fixed bin(18,0) dcl 13170 in procedure "make_symbol_descriptor" set ref 13284* 13285 13298 13299 13301* 13305 13309 desc 005630 automatic fixed bin(18,0) dcl 11460 in procedure "get_param_char_size" set ref 11464* 11470 11470 11470* 11476 11488 11494* 11495* 11502 11503* desc_image based char packed unaligned dcl 13335 in procedure "make_entry_descriptor" set ref 13434* desc_image based char packed unaligned dcl 13186 in procedure "make_symbol_descriptor" set ref 13277* 13291 desc_no parameter fixed bin(18,0) dcl 6227 ref 6219 6264 6276 6279 6279 desc_temp_chain 000672 automatic fixed bin(18,0) unsigned dcl 2536 set ref 2961* 4370 4372 4373* 11606 11607* descriptor 000117 automatic structure level 1 dcl 13173 in procedure "make_symbol_descriptor" set ref 13191* 13277 13291 descriptor 11(10) based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 2955* 6674 descriptor based structure array level 1 dcl 6380 in procedure "emit_eis" set ref 6451 descriptor 005661 automatic structure level 1 dcl 11546 in procedure "make_descriptor" set ref 11556* descriptor 006754 automatic structure level 1 dcl 13322 in procedure "make_entry_descriptor" set ref 13339* 13434 descriptor_mask_addr 000347 constant bit(36) initial dcl 2678 set ref 11483* 11598* descriptor_ptr constant fixed bin(18,0) initial dcl 2599 ref 7560 descriptor_relp 0(18) based fixed bin(18,0) array level 2 packed packed unsigned unaligned dcl 586 set ref 4113* 4115 14280 14281* descriptor_type_word 000345 automatic structure array level 1 dcl 628 set ref 11568 11572 13202 13206 13360 13364 dest 004302 automatic fixed bin(18,0) dcl 8382 set ref 8390* 8391 8395* 8403* 8405* 8410* 8423* 8428* 8429* 8440* dest_p 004310 automatic pointer dcl 8387 set ref 8391* 8395 8398 8410 8421* dfstr constant fixed bin(17,0) initial dcl 6182 ref 6212 diff 000112 automatic fixed bin(18,0) dcl 6947 set ref 6951* 6977* 7052 7052* 7052* dim builtin function dcl 7833 in procedure "find_ptr" ref 7842 dim 5 based structure array level 2 in structure "dimension" dcl 1-383 in procedure "fort_optimizing_cg" dim_no parameter fixed bin(18,0) dcl 10949 ref 10942 10952 dimension 12(25) based fixed bin(18,0) level 2 in structure "symbol" packed packed unsigned unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 1442 2364 3951 4138 10706 11104 11678 13228 13385 dimension based structure level 1 dcl 1-383 in procedure "fort_optimizing_cg" dimensioned 10(35) based bit(1) level 4 packed packed unaligned dcl 1-844 set ref 1487 1562 1905 3416 4191 7112 7128 11476 11491 11678 11701 11745 11813 13226 13383 13647 13769 directable 0(18) 000024 external static bit(1) array level 2 packed packed unaligned dcl 2578 ref 6105 6256 6347 discard 000674 automatic fixed bin(18,0) dcl 2539 set ref 4466* 4468* 4519 divide builtin function dcl 645 ref 760 790 808 900 989 1421 1650 1681 1697 1898 3119 5056 5367 10642 10644 11281 11283 12068 13803 13808 13811 13813 14102 14129 14252 do_rounding 000252 automatic bit(1) dcl 505 in procedure "code_generator" set ref 844* 4413 4494 4652 8974 9068 9115 9346 do_rounding 11(28) based bit(1) level 3 in structure "subprogram" packed packed unaligned dcl 1-753 in procedure "fort_optimizing_cg" ref 844 dollar_name 007141 automatic char(32) dcl 13965 set ref 13992* 13993* 14004* 14005* dominator 4 based pointer level 2 packed packed unaligned dcl 2-46 ref 10179 dont_update 0(22) based bit(1) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "fort_optimizing_cg" set ref 5388* 5586* 5679* dont_update 0(22) based bit(1) level 3 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "fort_optimizing_cg" set ref 10555* 11179* dont_update 0(22) based bit(1) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "fort_optimizing_cg" ref 8145 8854 double_target based bit(72) array dcl 13610 in procedure "initialize_symbol" set ref 13684* double_target based bit(72) array dcl 13732 in procedure "list_initialize_symbol" set ref 13839* dp_image based float bin(63) dcl 2708 set ref 2885* dp_mode 000753 constant fixed bin(4,0) initial dcl 4-106 set ref 2874* 2886* 4576 dt 000715 automatic fixed bin(4,0) dcl 2542 in procedure "interpreter" set ref 3037* 3040 3040* 3040* 3078* 3081 3083* 3083* 3084 3101* 3102 3103* 3261* 3271* 3498* 3501 3501 3507 dt 000101 automatic fixed bin(18,0) dcl 5351 in procedure "assign_temp" set ref 5353* 5354 5365* 5380* 5384 5392 dt 005656 automatic fixed bin(18,0) dcl 11543 in procedure "make_descriptor" set ref 11571* 11572 11573 dt 000111 automatic fixed bin(18,0) dcl 13170 in procedure "make_symbol_descriptor" set ref 13205* 13206 13207 dt 006746 automatic fixed bin(18,0) dcl 13319 in procedure "make_entry_descriptor" set ref 13363* 13364 13365 dt1 000716 automatic fixed bin(4,0) dcl 2542 set ref 3471* 3475 3478 3481 3493 dt2 000717 automatic fixed bin(4,0) dcl 2542 set ref 3473* 3484 3487 3490 3493 dt_from_reg 000400 constant fixed bin(4,0) initial array dcl 2614 ref 3261 3881 9430 dummy constant fixed bin(4,0) initial dcl 4-120 ref 1625 1644 1675 2941 e 005732 automatic fixed bin(17,0) dcl 11781 set ref 11785* 11786 11786 11787* 11787 11789 eaq 0(15) based bit(1) level 4 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 8636 eaq 2 001511 automatic structure array level 3 in structure "current_ms" dcl 2714 in procedure "interpreter" set ref 3197 8658 8824 9176 9533 9590 10262 10305 eaq 2 004574 automatic structure array level 3 in structure "new_state" dcl 9514 in procedure "merge_state" eaq 0(15) based bit(1) level 4 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "fort_optimizing_cg" set ref 3195 3205* 3206* 4481 eaq 2 parameter structure array level 3 in structure "existing_state" dcl 9514 in procedure "merge_state" eaq 0(15) based bit(1) level 4 in structure "node" packed packed unaligned dcl 1-63 in procedure "fort_optimizing_cg" set ref 3453 3829 3829 3839 3839 3848 3848 6518 6576 8034 8656 8771 8821 8870* 8883* 8966 9040* 9128* 9170 9322* 9535* 9610* 9717* eaq 2 parameter structure array level 3 in structure "affected_ms" dcl 10301 in procedure "drop_all_ms_ref_counts" eaq 000462 constant fixed bin(18,0) initial dcl 25-16 in procedure "interpreter" set ref 8435* eaq_name 0(22) based fixed bin(5,0) array level 2 in structure "macro_instruction" packed packed unaligned dcl 2758 in procedure "interpreter" set ref 3157 3456 3458 3528 3817 3820 3872 3888 3893 3913 4401 4585 4655 eaq_name 000711 automatic fixed bin(18,0) dcl 2540 in procedure "interpreter" set ref 3455* 3456 3458 3528* 3529 3820* 3829 3839 3839 3866* 3913* 3915 4401* 4402 4413 4413 4413 4413 4420 4425 4486* 4488 4491* 4494 4496 4655* 4656 4658 eaq_name 004507 automatic fixed bin(18,0) dcl 9149 in procedure "load" set ref 9151* 9153 9153 9167 9183 9183 9183 9187 9193 9215 9231 9233 9233* 9236* eaq_name 004541 automatic fixed bin(18,0) dcl 9339 in procedure "store" set ref 9342* 9346 9348 9355 9362* eaq_name_to_reg 000354 constant fixed bin(17,0) initial array dcl 2617 ref 3281 3529 3873 3915 4402 4658 8801 8857 9167 9431 eax0 constant fixed bin(18,0) initial dcl 25-16 ref 8034 8118 8210 8281 edge based structure level 1 dcl 2-33 element_count 2 based fixed bin(24,0) level 2 dcl 1-383 ref 2368 element_size 15(07) based fixed bin(17,0) level 2 packed packed unaligned dcl 1-844 set ref 1196 1564 1747 2311 2318 2368 2375 2456* 10659 10729 10739 10753 13235 13237 13292* 13392 13394 eligible_ind_var_op_var 37 based pointer level 2 packed packed unaligned dcl 2-100 ref 12317 empty_reg parameter fixed bin(3,0) dcl 7882 ref 7877 7892 7892 7892 7892 end_external_list 000206 automatic fixed bin(18,0) dcl 491 set ref 694* 13920 end_input_to 10(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-1005 set ref 27-79 27-82 27-85* 27-269* 27-273* end_offset 000106 automatic fixed bin(35,0) dcl 13567 in procedure "list_initialize" set ref 13572* 13578* end_offset parameter fixed bin(35,0) dcl 13708 in procedure "list_initialize_symbol" set ref 13700 13824 13828 13855* ent_name 007125 automatic bit(18) dcl 13958 set ref 13976* 14000* 14005* 14011* 14013 14030 ent_pos 007256 automatic fixed bin(18,0) dcl 14249 set ref 14256* 14260 14264 14264 14266 14268 14271 14278 entry based structure level 1 unaligned dcl 1982 in procedure "create_storage_entry" set ref 2211 2222 entry 000022 external static fixed bin(17,0) array level 2 in structure "fort_opt_macros_$operator_table" packed packed unaligned dcl 2574 in procedure "interpreter" ref 3311 entry 1(20) based bit(1) level 3 in structure "definition" packed packed unaligned dcl 8-12 in procedure "fort_optimizing_cg" set ref 14229* entry 000020 external static fixed bin(17,0) array level 2 in structure "fort_opt_macros_$interpreter_macros" packed packed unaligned dcl 2570 in procedure "interpreter" ref 5232 entry_info 7 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 set ref 7520 7562 13026* entry_info_size 000750 constant fixed bin(18,0) initial dcl 2676 set ref 13027* 13028 entry_type constant fixed bin(4,0) initial dcl 4-120 ref 1119 entry_unit 7 based pointer level 2 packed packed unaligned dcl 2-100 ref 10418 12397 ep 005740 automatic pointer dcl 11782 set ref 11789* 11791 11793 11796 11803 epaq constant fixed bin(18,0) initial dcl 25-16 ref 4148 equiv_chain 2(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 ref 1321 era 000432 constant fixed bin(18,0) initial dcl 25-16 set ref 12935* 12954* 12973* erases 25(01) based structure level 3 packed packed unaligned dcl 2-100 set ref 8548* 8548 11930* 11930 11930 erq 000431 constant fixed bin(18,0) initial dcl 25-16 set ref 12918* err_flag 000734 automatic bit(1) dcl 2547 set ref 3313* 3321* 3328 error_exit parameter fixed bin(18,0) dcl 5249 ref 5244 5276 error_label 5 based fixed bin(18,0) level 2 dcl 2718 set ref 3972 3989 5276* error_level 3 based fixed bin(17,0) level 2 dcl 52 ref 705 ersq 000430 constant fixed bin(18,0) initial dcl 25-16 set ref 12920* 12940* 12958* 12977* escape_address 000337 constant bit(36) initial dcl 9398 set ref 9412* 9440* escape_index constant fixed bin(18,0) initial dcl 2599 ref 8586 even 0(30) based bit(1) level 4 packed packed unaligned dcl 1-436 ref 1329 existing_state parameter structure level 1 dcl 9514 set ref 9509 exp_ptr 1 based bit(18) level 2 packed packed unaligned dcl 15-11 set ref 14042* exp_word based structure level 1 dcl 15-21 exponent 003542 automatic fixed bin(7,0) level 2 packed packed unaligned dcl 2842 set ref 4581 4584* 4584 4585* 4585 expression 2 based pointer level 3 packed packed unaligned dcl 2-234 set ref 4480 12408* ext_attributes 4 based structure level 2 packed packed unaligned dcl 1-844 ext_base 1(29) based bit(1) level 3 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "fort_optimizing_cg" set ref 2927* 10575* ext_base 1(29) based bit(1) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "fort_optimizing_cg" set ref 5713* ext_base 0(29) based bit(1) array level 3 in structure "instruction" packed packed unaligned dcl 2808 in procedure "interpreter" ref 5967 6161 ext_base 0(29) 001472 automatic bit(1) level 2 in structure "inst_address" packed packed unaligned dcl 2685 in procedure "interpreter" set ref 4147* ext_base 1(29) based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 1485* 1538* 1590* 1627* 1646* 1677* 2943* 2956* ext_base 1(29) based bit(1) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "fort_optimizing_cg" ref 4307 6127 6467 6890 6902 7226 11629 ext_base 0(29) 000101 automatic bit(1) level 2 in structure "inst_address" packed packed unaligned dcl 6778 in procedure "c_a" set ref 6807* ext_base 0(29) 000123 automatic bit(1) level 2 in structure "inst_address" packed packed unaligned dcl 7586 in procedure "base_man_store_temp" set ref 7594* ext_base_and_tag 0(29) based structure array level 2 in structure "instruction" packed packed unaligned dcl 2808 in procedure "interpreter" ext_base_and_tag 0(29) based structure array level 2 in structure "machine_instruction" packed packed unaligned dcl 2765 in procedure "interpreter" set ref 5868 ext_base_on constant bit(36) initial dcl 639 ref 1160 1226 1297 1349 1446 5508 5816 6060 7243 7444 7475 ext_ptr 1(18) based bit(18) level 2 packed packed unaligned dcl 15-25 set ref 14030* ext_ref based pointer array level 2 packed packed unaligned dcl 546 set ref 1805 1805 1805 1811 1811 1814 1851 1854* 1865* 13921 external constant fixed bin(4,0) initial dcl 4-120 in procedure "fort_optimizing_cg" ref 1434 1523 6332 external 10(31) based bit(1) level 4 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 1434 1518 1627* 3576 4317 6688 6734 11737 external_list based structure level 1 dcl 546 factor 000576 constant fixed bin(18,0) initial array dcl 1001 in procedure "get_size_in_bits" ref 1004 factor 000602 constant fixed bin(18,0) initial array dcl 982 in procedure "get_size_in_words" ref 989 989 falls_through 15(02) based bit(1) level 3 packed packed unaligned dcl 2-46 ref 11886 11916 12387 father 2 based pointer level 2 packed packed unaligned dcl 2-100 ref 10053 11930 11930 11932 11932 12144 12258 12352 12352 12355 fb17 2 based bit(1) level 4 packed packed unaligned dcl 2-243 ref 3555 fb18_uns 2(01) based bit(1) level 4 packed packed unaligned dcl 2-243 ref 8426 final_text_offset 11 000130 automatic fixed bin(18,0) level 2 dcl 58 set ref 798* first parameter fixed bin(18,0) dcl 7882 in procedure "get_free_reg" ref 7877 7899 first 13 based fixed bin(18,0) array level 3 in structure "subprogram" packed packed unsigned unaligned dcl 1-753 in procedure "fort_optimizing_cg" set ref 1204* 1276* 1306* 1369* 1604* 1733 1739 2302 13468 13476 13487 13540 first_auto_loc 000646 constant fixed bin(9,0) initial dcl 4-68 ref 1095 first_auto_var_loc 000326 automatic fixed bin(18,0) dcl 552 set ref 1698* 2913 2929 2932 13521 13521 13524 first_base 000755 constant fixed bin(18,0) initial dcl 2599 set ref 2860 3223 4265* 4353* 6959 6981* 6999* 7026* 7039* 7297 7389 7409 7418 7424 7430 7440* 7505 7515* 7547 7557* 7608 7637* 7679 7700 7761 7776 8595 8713 9556 9692 9773 9814 9849 9881 9903 9982 10274 10334 first_block_constant defined fixed bin(18,0) dcl 5-153 set ref 720* 888 first_char_constant defined fixed bin(18,0) dcl 5-149 set ref 684* 723* first_constant 100 based fixed bin(18,0) array level 3 dcl 47 set ref 12-89 12-89* 682 682 683 683 684 684 720 720 721 721 722 722 723 723 888 888 first_dw_constant defined fixed bin(18,0) dcl 5-145 set ref 682* 721* first_element 3(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-436 ref 1194 1745 1891 1930 2051 2308 8634 13542 13575 14159 first_entry_name 75 based fixed bin(18,0) level 2 dcl 47 ref 1026 1116 1528 11785 14254 first_frame 000154 automatic pointer dcl 479 set ref 663* 2977 2981* 2984 first_header 000212 automatic pointer initial dcl 496 set ref 496* 1989 1994 2006 2006* 2099 2202 2205* 2205 2205* 2206 2207* 2207* 2213 first_index 000755 constant fixed bin(18,0) initial dcl 2599 set ref 2861 3211 4504 4704* 8016 8028* 8106* 8112* 8206* 8242 8682 9539 9687 9781 9818 9853 9885 9908 9966 10268 10323 first_label 4 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 set ref 1035 1142 2489* first_lib_name 1 based fixed bin(18,0) level 2 unsigned dcl 52 ref 738 748 first_namelist 000210 automatic fixed bin(18,0) dcl 495 set ref 668* 801 1424* first_namelist_symbol 14 000130 automatic fixed bin(18,0) level 2 dcl 58 set ref 801* first_operator 1 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 2-176 ref 11953 27-139 13081 first_quad 10 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 ref 13021 first_statement 13 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 2-46 ref 11893 11951 12397 12480 13010 13068 13072 13072 first_stm 006263 automatic fixed bin(18,0) dcl 12460 set ref 12480* 12482 first_subprogram 72 based fixed bin(18,0) level 2 dcl 47 ref 1033 1132 1727 2295 2866 13463 13499 13519 first_symbol 3 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 ref 1380 4206 first_word_constant defined fixed bin(18,0) dcl 5-141 set ref 683* 722* first_xr parameter fixed bin(18,0) dcl 8164 ref 8158 8171 fixed builtin function dcl 645 ref 818 819 1497 1497 1841 1841 1844 1844 1847 1847 1851 1851 1948 1952 2022 2022 2025 2025 2160 2161 2272 2272 2389 2389 2973 3014 3334 3609 3618 3637 3689 3689 4029 4049 4115 4140 4143 4156 4158 4168 4443 4682 4737 4748 4948 4958 5272 5656 5870 5870 6021 6021 6085 6123 6123 6337 6455 6465 6465 6525 6557 6557 6568 6568 6600 6600 6624 6624 6643 6657 6657 6677 6677 6887 6887 6904 8005 8203 8227 8269 8279 8419 8478 8517 8746 8767 9475 10590 11141 11333 11633 11634 11971 12018 12020 12202 12436 12436 12657 27-78 27-143 27-148 27-193 27-269 27-275 12686 13076 13128 13128 13155 13155 13355 13573 13586 13883 14042 14078 14082 14132 14154 14154 flag 000345 automatic bit(1) initial array level 2 packed packed unaligned dcl 628 set ref 628* flags 1(18) based structure level 2 in structure "definition" packed packed unaligned dcl 8-12 in procedure "fort_optimizing_cg" flags 1(18) based bit(18) level 2 in structure "def_header" packed packed unaligned dcl 13871 in procedure "init_linkage" set ref 13891* flags 0(05) based structure level 2 in structure "proc_frame" packed packed unaligned dcl 2718 in procedure "interpreter" set ref 5270* flags 0(18) based structure level 2 in structure "create_entry" packed packed unaligned dcl 21-23 in procedure "code_generator" floating_value 003542 automatic structure level 1 dcl 2842 set ref 4579* 4587 4587 flow_unit 6 based pointer level 2 in structure "opt_statement" packed packed unaligned dcl 2-176 in procedure "fort_optimizing_cg" ref 4053 4065 flow_unit 3 based pointer level 3 in structure "primary" packed packed unaligned dcl 2-234 in procedure "fort_optimizing_cg" set ref 12409* flow_unit based structure level 1 dcl 2-46 in procedure "fort_optimizing_cg" format 12 based structure level 2 dcl 16-10 fort_instruction_info_$fort_instruction_info_ 000024 external static structure array level 1 dcl 2578 fort_make_symbol_section 000010 constant entry external dcl 62 ref 803 fort_opt_macros_$abort_list 000014 external static bit(36) dcl 2564 set ref 12686 fort_opt_macros_$error_macro 000016 external static bit(36) dcl 2564 set ref 10590 fort_opt_macros_$first_scan 000012 external static bit(36) dcl 2564 set ref 2972 2973 fort_opt_macros_$interpreter_macros 000020 external static structure array level 1 dcl 2570 fort_opt_macros_$operator_table 000022 external static structure array level 1 dcl 2574 fort_opt_macros_$single_inst 000026 external static structure array level 1 dcl 2610 ref 5899 5915 5932 5949 5965 6014 fortran_declared based structure level 1 dcl 6-91 fortran_options based structure level 1 dcl 6-40 forward based bit(18) level 2 packed packed unaligned dcl 8-12 set ref 14215* 14217* forward_refs based structure array level 1 dcl 568 set ref 727 found parameter bit(1) dcl 11098 in procedure "get_virtual_origin" set ref 11089 11108* 11115* 11120* found 006126 automatic bit(1) dcl 12163 in procedure "ok" set ref 12167* 12168 12169* 12173 found 006554 automatic bit(1) dcl 27-242 in procedure "disconnect_temporary" set ref 27-248* 27-251 27-252* 27-260 found 006236 automatic bit(1) dcl 12310 in procedure "check_comparisons_and_increments" set ref 12323* 12328* 12339* 12344 12362* 12364 12365* 12370 found_error 006632 automatic bit(1) initial packed unaligned dcl 12735 in procedure "rhs_fld" set ref 12735* 12741* 12747* 12753* 12755 found_error 006654 automatic bit(1) initial packed unaligned dcl 12844 in procedure "lhs_fld" set ref 12844* 12851* 12857* 12863* 12869* 12871 fptype 000363 automatic fixed bin(1,0) initial dcl 637 set ref 637* 11568 11572 13202 13206 13360 13364 free 000236 automatic pointer array dcl 502 in procedure "code_generator" set ref 672* 12669 12670* 27-34 27-37 27-38* 27-38 free 24 based pointer array level 2 in structure "shared_globals" dcl 47 in procedure "fort_optimizing_cg" ref 672 free_reg 000126 automatic fixed bin(3,0) dcl 7587 set ref 7607* 7609* 7637* free_temps 000327 automatic fixed bin(18,0) array dcl 553 set ref 669* 669* 669* 5413 5417* 5425 5431* 5449 5450* 5730 5763 5764* 13037 13039 13044 13045* freed 0(10) based bit(1) level 2 packed packed unaligned dcl 2-144 set ref 12576* freei 32 based pointer level 2 in structure "shared_globals" dcl 47 in procedure "fort_optimizing_cg" ref 673 freei 000244 automatic pointer dcl 503 in procedure "code_generator" set ref 673* 27-94 27-97 27-98* 27-98 from_base_man 000740 automatic bit(1) dcl 2551 set ref 2964* 6595 7190* 7308* fstr constant fixed bin(17,0) initial dcl 6182 ref 6212 ft2 0(30) based bit(6) level 2 packed packed unaligned dcl 15-11 set ref 14039* ft_char_dtype constant fixed bin(17,0) initial dcl 22-96 ref 628 628 ft_complex_dtype constant fixed bin(17,0) initial dcl 22-96 ref 628 ft_double_dtype constant fixed bin(17,0) initial dcl 22-96 ref 628 ft_external_dtype constant fixed bin(17,0) initial dcl 22-96 ref 628 628 ft_hex_complex_dtype constant fixed bin(17,0) initial dcl 22-96 ref 628 ft_hex_double_dtype constant fixed bin(17,0) initial dcl 22-96 ref 628 ft_hex_real_dtype constant fixed bin(17,0) initial dcl 22-96 ref 628 ft_integer_dtype constant fixed bin(17,0) initial dcl 22-96 ref 628 628 ft_logical_dtype constant fixed bin(17,0) initial dcl 22-96 ref 628 628 ft_real_dtype constant fixed bin(17,0) initial dcl 22-96 ref 628 fu 005234 automatic pointer dcl 10165 in procedure "definitely_initialized" set ref 10176* 10176* 10177* 10179 fu 000652 automatic pointer dcl 2518 in procedure "interpreter" set ref 4053 4058 4061 4061* 4065* 4067 4072 4663 4691* 4696 4722 9959 10001 10418 12991* fu 006364 automatic pointer dcl 12651 in procedure "process_loop_end_lists" set ref 12654* 12655 12657 12659 12663 12670 12671 12672 fu parameter pointer dcl 11871 in procedure "reset_scan" set ref 11866 11880 11880 11886 11888 11893 11902 11908 11909* 11909 11911 11916 11918 11947* 11951 fu 006704 automatic pointer dcl 13057 in procedure "reset_subprogram" set ref 13067* 13067* 13068 13068 13072 13072* 13096 fu_to_put 006516 automatic pointer dcl 27-182 set ref 27-187* 27-192 27-194 27-195 27-195 27-205 full_pointer based pointer dcl 13459 set ref 13471* func 0(05) based bit(1) level 3 packed packed unaligned dcl 2718 set ref 3144 3154 5272* func_ref_op constant fixed bin(18,0) initial dcl 4-197 ref 12491 function constant fixed bin(18,0) initial dcl 2667 ref 3334 5272 gap_value constant fixed bin(17,0) initial dcl 4-57 ref 13650 13668 13796 general 6(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-844 set ref 11502 11523 11686 11688 11694* 11718 11793 11796* 11796 11803 13293* 13350 generate_long_profile 000246 automatic bit(1) dcl 505 set ref 847* 1043 1710 4973 10449 10455 13506 generate_profile 000247 automatic bit(1) dcl 505 set ref 846* 1707 4086 4973 13506 generate_symtab 000250 automatic bit(1) dcl 505 set ref 848* 1618 1767 get_next_temp_segment 1534 based entry variable level 2 dcl 47 ref 27-22 getlp 000456 constant fixed bin(18,0) initial dcl 25-16 set ref 7657* 8609* 10439* global 41 based bit(1) array level 5 in structure "loop_state" packed packed unaligned dcl 9839 in procedure "enter_loop" ref 9854 global 112 parameter bit(1) array level 5 in structure "existing_state" packed packed unaligned dcl 9514 in procedure "merge_state" set ref 9558* global 41 based bit(1) array level 5 in structure "machine_state" packed packed unaligned dcl 1-620 in procedure "fort_optimizing_cg" set ref 10078* global 112 based bit(1) array level 5 in structure "machine_state" packed packed unaligned dcl 1-620 in procedure "fort_optimizing_cg" set ref 10085* global 41 parameter bit(1) array level 5 in structure "existing_state" packed packed unaligned dcl 9514 in procedure "merge_state" set ref 9541* global 41 001511 automatic bit(1) array level 5 in structure "current_ms" packed packed unaligned dcl 2714 in procedure "interpreter" set ref 4674 9819* 9854* 9886* 9967 global parameter bit(1) array level 3 in structure "regs" packed packed unaligned dcl 7882 in procedure "get_free_reg" ref 7892 7900 global 112 001511 automatic bit(1) array level 5 in structure "current_ms" packed packed unaligned dcl 2714 in procedure "interpreter" set ref 7450* 9815* 9850* 9882* 9983 global 112 based bit(1) array level 5 in structure "loop_state" packed packed unaligned dcl 9839 in procedure "enter_loop" ref 9850 global_pr_items 34 based pointer level 2 packed packed unaligned dcl 2-100 set ref 12136 12221 12222* 12248 12250* global_reg parameter fixed bin(3,0) dcl 7882 ref 7877 7889 7889 global_xr_items 33 based pointer level 2 packed packed unaligned dcl 2-100 set ref 12132 12212 12213* 12241 12243* globally_assigned 0(24) based bit(1) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "fort_optimizing_cg" set ref 3542 3568 8242 9821* 9856* globally_assigned 0(24) based bit(1) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "fort_optimizing_cg" set ref 5680* globally_assigned 0(24) based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 8398 grow parameter bit(18) dcl 13953 ref 13950 13983 14025 14026 grow_info 007222 automatic bit(18) dcl 14117 set ref 14143* 14144 14182 grow_pt 007212 automatic pointer dcl 14111 set ref 14144* 14145 14155 14171 14172 h 000100 automatic pointer dcl 13564 in procedure "list_initialize" set ref 13569* 13570 13575 h parameter pointer dcl 2232 in procedure "make_create_entry" ref 2229 2240 2241 2241 2243 2246 2247 2248 2249 2250 2252 2253 2255 2256 2261 h 007206 automatic pointer dcl 14111 in procedure "initialize_common" set ref 14126* 14129 14132 14135 14136 14140 14149 14154 14154 14159 h 007034 automatic pointer dcl 13534 in procedure "initialize" set ref 13541* 13542 13542 13548* 13549 h parameter pointer dcl 1919 in procedure "create_storage_entry" set ref 1911 1928* 1930 1930 1933 1937 1941 1962 1995 2017 2022 2022 2022 2022 2022 2022 2025 2025 2027 2027 2051 2223 h 007016 automatic pointer dcl 13456 in procedure "initialize_static" set ref 13469* 13470 13472 13477* 13478 13483 13488* 13489 13494 h 000110 automatic pointer dcl 1078 in procedure "assign_storage" set ref 1156* 1157 1159 1160 1161 1165 1169 1174 1175 1184 1185 1190* 1194 1199 1213 1214 1221* 1222 1224 1225 1226 1227 1227 1230 1231 1238 1241 1242 1244 1247* 1253 1256 1256 1264 1264 1268 1269* 1270 1285 1286 1293* 1294 1296 1297 1298 1302 1302* 1315 1316 1323* 1324 1329 1332 1334 1339 1344 1345 1349 1350 1351 1353 1354 1356 1357 1358 1374 1375 1734* 1735 1735 1736 1740* 1742 1744 1744 1745 1752 1752* 1754 1756 1891 1893 1894 1895 1898 1901 1903 2303* 2305 2307* 2308 2317* 2318* 2318 2318 2320 h_bound 2 000117 automatic fixed bin(18,0) array level 3 in structure "descriptor" dcl 13173 in procedure "make_symbol_descriptor" set ref 13247* 13263* 13265* 13267* h_bound 2 006754 automatic fixed bin(18,0) array level 3 in structure "descriptor" dcl 13322 in procedure "make_entry_descriptor" set ref 13404* 13420* 13422* 13424* half based structure level 1 dcl 2825 half_array 1 based fixed bin(17,0) array level 2 packed packed unaligned dcl 2754 ref 3117 3495 3507 3513 3678 has_address 0(35) based bit(1) level 3 packed packed unaligned dcl 1-155 set ref 6118 6564 6882 10557 10664* has_array_size 0(24) based bit(1) level 2 packed packed unaligned dcl 1-383 set ref 2369* 2394 2397* has_dim_sizes 0(25) based bit(1) level 2 packed packed unaligned dcl 1-383 set ref 2422 2432* has_operator_list 4(05) based bit(1) level 3 packed packed unaligned dcl 2-176 set ref 12406* has_virtual_origin 0(23) based bit(1) level 2 packed packed unaligned dcl 1-383 set ref 2382* 2405 2415* 10730* 10792* hash_chain 3(18) based fixed bin(18,0) level 2 in structure "node" packed packed unsigned unaligned dcl 1-63 in procedure "fort_optimizing_cg" set ref 12-69 12-78* hash_chain 2 based fixed bin(18,0) level 2 in structure "pointer" dcl 1-672 in procedure "fort_optimizing_cg" set ref 7854 7868* hash_chain 3(18) based fixed bin(18,0) level 2 in structure "symbol" packed packed unsigned unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 1120* 1385* 1401* 1904* 4219 4219 4221 4222 4379* 10696 11464 11521 11561 11561 13197 13197 13305* 13345 13347 13438* hash_index 000117 automatic fixed bin(17,0) dcl 7831 in procedure "find_ptr" set ref 7842* 7846 7868 7869 hash_index 000105 automatic fixed bin(17,0) dcl 12-24 in procedure "create_constant" set ref 12-57* 12-61 12-76 12-76 hash_table based fixed bin(35,0) array dcl 12-25 set ref 12-61 12-76 12-76* hash_table_size 074411 constant fixed bin(17,0) initial dcl 12-26 ref 12-57 hast based structure level 1 unaligned dcl 2754 have_eligible 000104 automatic bit(1) dcl 8002 set ref 8009* 8010 8054 have_zero 004330 automatic bit(1) dcl 8457 set ref 8469* 8470* 8480 8484 hbound builtin function dcl 12-27 in procedure "create_constant" ref 12-43 hbound builtin function dcl 645 in procedure "code_generator" ref 727 3197 3355 3355 4284 5136 5138 7805 8351 8658 8824 8872 8879 9176 9533 9590 9646 9660 10262 10305 11121 14076 14166 hdr parameter fixed bin(18,0) dcl 13559 in procedure "list_initialize" ref 13556 13569 hdr 000126 automatic fixed bin(18,0) dcl 1079 in procedure "assign_storage" set ref 1154* 1155 1156 1199* 1204 1206 1207 1213* 1219* 1220 1221 1270* 1276 1278 1279 1285* 1291* 1292 1293 1306 1308 1309 1315* 1321* 1322 1323 1369 1371 1372 1374* 1733* 1733* 1734* 1739* 1739* 1740* 2302* 2302* 2303* hdr 000110 automatic pointer dcl 1973 in procedure "create_storage_entry" set ref 1994* 1994* 1995* 1997 2001 2006 2008 2009 2015 2017 2022 2027 2027 2034* 2034* 2035 2039 2041 2042 2049 2072 2073 2074 2075 2076 2128* 2128* 2129 2130 2130 2131 2131* 2133 2139* 2139 2139* 2140* 2164 2209* 2210 2211 2222* 2223 2224 2224 2225 2226 hdr 007041 automatic fixed bin(18,0) dcl 13535 in procedure "initialize" set ref 13540* 13540* 13541* hdr 007013 automatic fixed bin(18,0) dcl 13455 in procedure "initialize_static" set ref 13468* 13468* 13469* 13476* 13476* 13477* 13487* 13487* 13488* head_address based fixed bin(35,0) dcl 13961 set ref 14038* header 6 based bit(1) level 2 in structure "entry" packed packed unaligned dcl 1982 in procedure "create_storage_entry" set ref 2034 2075* 2128 2226* header 002543 automatic structure level 2 in structure "arg_list" dcl 2829 in procedure "interpreter" set ref 4322* header based structure level 1 dcl 1-436 in procedure "fort_optimizing_cg" header_length 000104 automatic fixed bin(24,0) dcl 1799 set ref 1818* 1820* 1822* 1824 1824 1830* 1832* 1834* 1836 1839 1841 1841 1844 1844 1847 header_node constant fixed bin(4,0) initial dcl 4-87 ref 1742 1811 1867 2305 13542 hfp 12(04) based bit(1) level 3 in structure "subprogram" packed packed unaligned dcl 1-753 in procedure "fort_optimizing_cg" ref 5075 hfp 114(04) based bit(1) level 4 in structure "shared_globals" packed packed unaligned dcl 47 in procedure "fort_optimizing_cg" ref 637 2966 highest_ind_state constant fixed bin(17,0) initial dcl 2663 ref 6208 8050 8120 8218 8282 8480 8484 9401 9404 9428 9435 hold_last_auto_loc 000334 automatic fixed bin(18,0) dcl 556 set ref 1013* 1047 hold_pr_locks 001503 automatic bit(1) array dcl 2697 set ref 7762* 7777 hold_text_pos 000333 automatic fixed bin(18,0) dcl 556 set ref 1014* 1046 i 005672 automatic fixed bin(18,0) dcl 11622 in procedure "set_itp_addr" set ref 11625* 11627 11631 11632 11633 11634 11638 11641 i 005456 automatic fixed bin(3,0) dcl 10950 in procedure "compute_dimension_size" set ref 10952* 10958 10960 10962 10963 10970 10972 10983 10984 10991 10992 10994 10995 10999 11003 11004 11006 11006 11007 11008 11011 11015 11016 11018 11019 11021 11023 i 005136 automatic fixed bin(17,0) dcl 9955 in procedure "refresh_regs" set ref 9966* 9967 9967 9971 9971* 9982* 9983 9983 9983 9983 9983 9983 9983 9983* i 005366 automatic fixed bin(18,0) dcl 10485 in procedure "setup_message_structure" set ref 10490* 10499 10500 10507 10508 10509* i parameter fixed bin(18,0) dcl 5132 in procedure "push" ref 5127 5142 i 000103 automatic fixed bin(3,0) dcl 8001 in procedure "xr_man_load_any_xr" set ref 8016* 8017 8017 8020 8021* 8028* 8030* 8034 8047 8050 8052* 8058 i 004037 automatic fixed bin(18,0) dcl 6395 in procedure "emit_eis" set ref 6403* 6404 6404 6405 6405 6406 6406 6407* 6440* 6444 6444 6446 6446 6451 6453 6453 6455 6457 6460 6460 6463 6465 6465 6465 6465* 6467 6467 6467 6467 6467 6471 6472 6479 6479 6479* i 006354 automatic fixed bin(17,0) dcl 12649 in procedure "process_loop_end_lists" set ref 12653* 12654* i 000142 automatic fixed bin(18,0) dcl 2233 in procedure "make_create_entry" set ref 2272* 2273 i 000101 automatic fixed bin(3,0) dcl 7374 in procedure "base_man_load_large_base" set ref 7387* 7390* 7407 7409* 7414 7414 7414* 7418* 7420 7420 7420* 7424* 7426 7426 7426* 7430* 7432 7432 7432* 7437 7440* 7442* 7447 7448 7450 7450 7453 7454 7455 7456 7458 i parameter fixed bin(3,0) dcl 7139 in procedure "flush_base" ref 7134 7142 7144 7154 7166 i 000321 automatic fixed bin(18,0) dcl 534 in procedure "code_generator" set ref 727* 728 729* 747* 751 752 753 754* 754 14279* 14280 14281* i 005266 automatic fixed bin(18,0) dcl 10260 in procedure "bump_all_ms_ref_counts" set ref 10263* 10264 10264* 10268* 10270 10270 10270* 10274* 10276 10276 10276* i 000101 automatic fixed bin(17,0) dcl 8238 in procedure "find_global_index" set ref 8242* 8244 8244 8244 8244* i 007042 automatic fixed bin(18,0) dcl 13535 in procedure "initialize" set ref 13539* 13540* i 000116 automatic fixed bin(18,0) dcl 8650 in procedure "flush_simple_ref" set ref 8659* 8659* 8660 8662* 8662 8662* 8663 8663* 8682* 8682* 8684 8684 8687* 8692 i 004212 automatic fixed bin(3,0) dcl 7774 in procedure "restore_pr_locks" set ref 7776* 7777 7777* i 005703 automatic fixed bin(18,0) dcl 11665 in procedure "check_arg_list" set ref 11676* 11677 11678* 11698* 11699 11700 11704 11705 11708 11709* 11727* 11728 11737 11737 11747 11749 11753 11756* 11768 i 006056 automatic fixed bin(17,0) dcl 12060 in procedure "sort_globals" set ref 12070* 12071* i 006666 automatic fixed bin(17,0) dcl 12988 in procedure "start_subprogram" set ref 13014* 13015 13015* 13036* 13037 13039 13044 13045* i 006042 automatic fixed bin(17,0) dcl 12009 in procedure "allocate_registers" set ref 12025* 12026* 12036* 12037* i 004473 automatic fixed bin(18,0) dcl 9103 in procedure "flush_eaq" set ref 9119* 9121 9123* i 000100 automatic fixed bin(18,0) dcl 7887 in procedure "get_free_reg" set ref 7899* 7900 7900 7902 7902 7905 7905 7905 7912 7913 7916 7919 7920* i 000106 automatic fixed bin(18,0) dcl 13170 in procedure "make_symbol_descriptor" set ref 13239* 13241 13244 13246 13246 13247 13247 13248 13258 13258 13258 13260 13263 13263 13263 13265 13265 13267* i 004234 automatic fixed bin(18,0) dcl 8166 in procedure "const_in_xr" set ref 8171* 8172 8172 8174 8174 8177* i 000125 automatic fixed bin(3,0) dcl 7587 in procedure "base_man_store_temp" set ref 7608* 7609 7609 7611 7611 7611* 7637* 7640 7640 7642* 7649* 7651 7654* i 005232 automatic fixed bin(17,0) dcl 10164 in procedure "definitely_initialized" set ref 10174* 10177 i 006235 automatic fixed bin(17,0) dcl 12309 in procedure "check_comparisons_and_increments" set ref 12334* 12334* 12337 12340 i 005026 automatic fixed bin(3,0) dcl 9768 in procedure "discard_state" set ref 9773* 9775* 9781* 9783 9783 9783* i 000112 automatic fixed bin(18,0) dcl 9054 in procedure "save_logical_temps" set ref 9060* 9060* 9061 9061* 9072* 9073 9083* i 000675 automatic fixed bin(18,0) dcl 2540 in procedure "interpreter" set ref 3112* 3114 3114 3117 3157* 3158 3199* 3200 3200* 3211* 3212 3212 3212* 3223* 3224 3224 3224* 3261 3280* 3281 3281 3320* 3320* 3321 3323* 3337* 3338 3341* 3342 3378* 3381 3381 3383 3397* 3400 3400 3407* 3409 3478* 3481* 3487* 3490* 3493* 3495 3674* 3676 3676 3678 3729* 3730 3730 3940* 3941* 4112* 4113 4113 4115 4116* 4124* 4125 4127 4137 4165 4166* 4175* 4176 4181 4183* 4189* 4190 4196* 4262* 4266 4270 4270 4273* 4298* 4299 4301* 4328* 4329 4330* 4331* 4348* 4349 4355 4355 4361* 4418* 4420* 4421* 4451* 4453* 4494* 4496* 4498* 4504* 4504 4504* 4508 4551* 4553* 4560* 4562* 4636* 4638 4638 4641 4690* 4691 4691 4691* 4696 4796* 4796* 4803 4805* i 004116 automatic fixed bin(3,0) dcl 6870 in procedure "make_both_addressable" set ref 6873* 6875 6880 6890* i 004130 automatic fixed bin(3,0) dcl 7182 in procedure "base_man_load_pr" set ref 7192* 7220* 7226 7230 7233* 7235 7244 7289 7290 7291 7295 7296* 7297 7297 7297 7300 7304 i 004050 automatic fixed bin(17,0) dcl 6504 in procedure "get_eis_length" set ref 6507* 6509 6514 6515 6518 6520 6521 6525 6525 6529 6529 6529 6534 i 004246 automatic fixed bin(18,0) dcl 8194 in procedure "xr_man_add_const" set ref 8199* 8203 i 004201 automatic fixed bin(3,0) dcl 7757 in procedure "avoid_prs" set ref 7761* 7762 7762 7763 7763* i 004366 automatic fixed bin(18,0) dcl 8577 in procedure "free_regs" set ref 8586* 8587 8589 8590 8590* 8595* 8596 8598 8599 8599* 8606* 8607 8607 8610 8613 i 000113 automatic fixed bin(18,0) dcl 5406 in procedure "get_temp" set ref 5412* 5413 5417 5423* 5442 i 007172 automatic fixed bin(18,0) dcl 14062 in procedure "name_assign" set ref 14076* 14077* i 003644 automatic fixed bin(18,0) dcl 5188 in procedure "get_operand" set ref 5198* 5200 i 000104 automatic fixed bin(18,0) dcl 6616 in procedure "m_a_except_xreg" set ref 6640* 6648* 6662* 6664* 6669* 6672* 6674* 6681* 6683* i 000104 automatic fixed bin(18,0) dcl 8706 in procedure "flush_addr" set ref 8713* 8713* 8714 8714 8717* 8731 i 005516 automatic fixed bin(17,0) dcl 11101 in procedure "get_virtual_origin" set ref 11112* 11112* 11113* i 000121 automatic fixed bin(18,0) dcl 6720 in procedure "m_a_check_large_address" set ref 6738* 6740 6740* i 000100 automatic fixed bin(3,0) dcl 7539 in procedure "base_man_load_desc_ptr" set ref 7547* 7548 7548 7550 7552 7553* 7557* 7558* 7564 7566 7567 7568 7569 7571 i 000106 automatic fixed bin(18,0) dcl 9317 in procedure "reset" set ref 9321* 9321* 9322* i 000164 automatic fixed bin(18,0) dcl 2290 in procedure "relocate" set ref 2299* 2300 2300 2302 2322* 2341 i 000104 automatic fixed bin(17,0) dcl 1923 in procedure "create_storage_entry" set ref 2138* 2141* 2141 2143 2153 2154 2160 i 000130 automatic fixed bin(18,0) dcl 1079 in procedure "assign_storage" set ref 1171* 1179* 1204 1204 1206 1207 1246* 1255* 1262* 1276 1276 1278 1279 1329* 1331* 1332* 1332 1334* 1334 1339 1339 1339 1343 1344 1344 1345 1345 1345 1365* 1369 1369 1371 1372 1406* 1411* 1413* 1429* 1433* 1554* 1568* 1570* 1571* 1571 1573* 1573 1578 1579 1579 1600* 1604 1604 1606 1607 i 005042 automatic fixed bin(17,0) dcl 9808 in procedure "leave_loop" set ref 9814* 9815* 9818* 9819 9821 9821* i 000100 automatic fixed bin(18,0) dcl 8624 in procedure "flush_ref" set ref 8634* 8634* 8635 8636* i 006717 automatic fixed bin(17,0) dcl 13059 in procedure "reset_subprogram" set ref 13064* 13065* i 007110 automatic fixed bin(18,0) dcl 13916 in procedure "gen_linkage" set ref 13920* 13921 13937 13937* i 000100 automatic fixed bin(3,0) dcl 8139 in procedure "xr_man_update_xr" set ref 8143* 8148 8149 8152 8154 i 006744 automatic fixed bin(18,0) dcl 13319 in procedure "make_entry_descriptor" set ref 13396* 13398 13401 13403 13403 13404 13404 13405 13415 13415 13415 13417 13420 13420 13420 13422 13422 13424* i 004264 automatic fixed bin(3,0) dcl 8265 in procedure "xr_man_load_xr" set ref 8279* 8281* 8281* i 005106 automatic fixed bin(17,0) dcl 9899 in procedure "adjust_state_for_globals" set ref 9903* 9904 9904 9904* 9908* 9909 9914 9914 9915* i 005433 automatic fixed bin(18,0) dcl 10682 in procedure "get_param_array_size" set ref 10765* 10778 10778 10780 10781 10785 10785 10790 10845 10848 10857 10857 10864 10864 10866 10866 10875* 10883 10891 10891 10893 10899 10899 10899 10901 10912* 10927* 10929* 10930* 10930* 10931 10933 10935* i 004355 automatic fixed bin(18,0) dcl 8542 in procedure "reserve_regs" set ref 8551* 8552 8552 8555 8562* i 005120 automatic fixed bin(17,0) dcl 9928 in procedure "cleanup_loop_state_nodes" set ref 9931* 9932* i 005546 automatic fixed bin(17,0) dcl 11208 in procedure "start_cat" set ref 11214* 11215* i 005733 automatic fixed bin(17,0) dcl 11781 in procedure "find_arg_desc" set ref 11805* 11806 11808* 11827 i 005311 automatic fixed bin(18,0) dcl 10303 in procedure "drop_all_ms_ref_counts" set ref 10306* 10307 10307 10312* 10323* 10325 10327 10327 10329 10329* 10334* 10336 10338 10338 10340 10340* i 000217 automatic fixed bin(18,0) dcl 2358 in procedure "get_array_size" set ref 2376* 2377 2378* 2389* 2408* 2409* 2424* 2425 2425 2425 2425 2428 2428 2428 2428 2430* i 000100 automatic fixed bin(3,0) dcl 7497 in procedure "base_man_load_arg_ptr" set ref 7505* 7506 7506 7508 7510 7511* 7515* 7516* 7522 7524 7525 7526 7527 7529 i 000106 automatic fixed bin(3,0) dcl 6945 in procedure "base_man_load_any_pr" set ref 6959* 6960 6960 6962 6962 6962 6966 6967 6969* 6981* 6983* 6985 6999* 7001* 7011* 7013 7026* 7028* 7030 7039* 7041* 7049 7052 7055 7056 7057 7058 7059 i 005414 automatic fixed bin(18,0) dcl 10538 in procedure "optimized_subscript" set ref 10618* 10623* 10631* 10631 10634* 10634 10637* 10637 10641 10642 10642* 10642 10644* 10644 10649 10659* i 004423 automatic fixed bin(18,0) dcl 8848 in procedure "in_reg" set ref 8879* 8881 8883 8884* i 004761 automatic fixed bin(18,0) dcl 9516 in procedure "merge_state" set ref 9534* 9535* 9539* 9541 9543 9543 9546 9547 9547 9552* 9556* 9558 9560 9560 9563 9567 9575* 9600* 9601 9603 9610 9612 9612 9616 9624* 9624 i 005072 automatic fixed bin(17,0) dcl 9872 in procedure "refresh_global_bits" set ref 9881* 9882* 9885* 9886* i 000103 automatic fixed bin(17,0) dcl 7671 in procedure "find_global_base" set ref 7679* 7680 7680 7680 7680 7680* i 005056 automatic fixed bin(17,0) dcl 9841 in procedure "enter_loop" set ref 9849* 9850 9850* 9853* 9854 9854 9856 9856* i 004222 automatic fixed bin(3,0) dcl 8101 in procedure "xr_man_load_const" set ref 8112* 8114* 8118 8120 8122 8123 8124 8129 i 004454 automatic fixed bin(18,0) dcl 8948 in procedure "save" set ref 8978* 8978* 8980 8993* i 006565 automatic fixed bin(18,0) dcl 27-287 in procedure "in_namelist" set ref 27-292* 27-293* i 005771 automatic fixed bin(18,0) dcl 11846 in procedure "replace_inputs" set ref 11851* 11852 11855 i 004146 automatic fixed bin(3,0) dcl 7320 in procedure "base_man_load_pr_value" set ref 7326* 7330 7330 7330 7339* 7346 7350 7351 7352 7356 7361 i 004511 automatic fixed bin(18,0) dcl 9149 in procedure "load" set ref 9178* 9178* 9180* i 000103 automatic fixed bin(18,0) dcl 1797 in procedure "alloc_external" set ref 1803* 1805 1805 1805* 1810* 1811 1811 1814 1818 1820 1824 1824 1830 1832 1836 1839 1841 1847 1851 1854* i 006264 automatic fixed bin(18,0) dcl 12460 in procedure "propagate_and_eliminate_assignment" set ref 12497* 12498* i parameter fixed bin(18,0) dcl 27-66 in procedure "chain_input" ref 27-62 27-77 i 000100 automatic fixed bin(18,0) dcl 8068 in procedure "flush_xr" set ref 8078* 8080 8085 8085 i_loop 001447 automatic fixed bin(17,0) dcl 2558 set ref 11937* 11937 11937* 11940 11946 13003* 13003* 13006 13010 i_non_const 006232 automatic fixed bin(18,0) dcl 12308 set ref 12329* 12340* 12350 12436* identifier 1 based char(8) level 2 dcl 16-10 set ref 812* if_test 0(27) based bit(1) array level 2 packed packed unaligned dcl 2800 ref 3413 3421 3533 3539 3545 3551 3558 3564 3573 3579 3584 3590 3595 4034 4280 4887 4896 4902 4907 4913 4920 4931 5073 ii 005734 automatic fixed bin(17,0) dcl 11781 set ref 11804* 11808 11809 11811 11812 11816 11817 11820 11821 11824* 11824 11827 11832 11833 11834 imac 000660 automatic fixed bin(18,0) dcl 2523 set ref 2973* 2996* 2996 3000 3012 3013 3014 3037 3078 3083 3083 3084* 3084 3101 3117 3119* 3119 3126* 3131* 3131 3132* 3132 3135* 3157 3293* 3302* 3341 3342* 3346 3347* 3357 3358* 3365* 3381 3383 3400 3409 3413 3421 3456 3458 3495* 3495 3507* 3507 3513* 3513 3528 3533 3539 3545 3551 3558 3564 3573 3579 3584 3590 3595 3633 3637 3666* 3678* 3678 3682* 3682 3682* 3685* 3688* 3688 3688* 3689 3689 3690* 3746 3793 3817 3820 3862* 3872 3888 3893 3913 3989* 3994* 4029 4034 4280 4388* 4401 4585 4588* 4643* 4655 4851* 4887 4896 4902 4907 4913 4920 4931 5073 5234* 5234* 5239* 5868 5870 5870 5871 5878 5879 5881 6399* 6399 6404 6406 6418 6435 6436 6441* 6441 6509 6525 10488 10491* 10491 10493 10500 10508 10509 10590* 12686* image based fixed bin(18,0) array dcl 529 set ref 872* 872 in_a constant fixed bin(18,0) initial dcl 2627 ref 3829 4491 9038 9201 9215 10962 10963 10983 10984 11003 11004 11015 11016 in_common 006266 automatic bit(1) dcl 12461 in procedure "propagate_and_eliminate_assignment" set ref 12476* 12491 in_common 11(02) based bit(1) level 4 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 6667 7117 12476 in_common 0(35) based bit(1) level 4 in structure "header" packed packed unaligned dcl 1-436 in procedure "fort_optimizing_cg" ref 1244 2241 2248 in_deaq constant fixed bin(18,0) initial dcl 2627 ref 4413 4413 6212 in_eaq constant fixed bin(18,0) initial dcl 2627 ref 4413 6212 in_equiv_stmnt 11(08) based bit(1) level 3 packed packed unaligned dcl 1-844 set ref 8630 in_ia constant fixed bin(18,0) initial dcl 2627 set ref 8776 8788 8790 12816* 12821* 12933 12952 12970 in_ind constant fixed bin(18,0) initial dcl 2627 ref 3281 3456 3456 3524 4488 8864 9024 9031 9153 9193 9233 9407 9410 9410 9443 in_iq constant fixed bin(18,0) initial dcl 2627 ref 12936 12955 12974 in_q constant fixed bin(18,0) initial dcl 2627 set ref 4210 4221 4222 5838* 7084 8440* 8774 8786 8792 8805 9183 9183 9355 10738* 10740* 10808* 10811* 10812* 10821* 10824* 10828* 10845 10848 10857* 10885 10890* 10899* 10901* 10907* 10919* 10931 10933 10935 10991* 10992 10995* 11006* 11008* 11018* 11019 11023* 11033* 11304* 11306* 11313* 11317* 11482 11484 11503 11597* 11600 in_tq constant fixed bin(18,0) initial dcl 2627 set ref 9183 9183 12766* 12784* 12804* 12898* 12899* 12907* 12910* inc parameter fixed bin(18,0) dcl 6225 in procedure "text_ref" ref 6219 6256 6325 6342 6342 inc parameter fixed bin(18,0) dcl 940 in procedure "assign_address_offset" ref 933 944 inc 003746 automatic fixed bin(18,0) dcl 5895 in procedure "emit_single" set ref 5897* 5899* 5912* 5915* inc parameter fixed bin(18,0) dcl 6075 in procedure "put_word" ref 6069 6108 6116 6129 6144 6159 6161 6161 6165 6166 inc parameter fixed bin(18,0) dcl 6754 in procedure "increment_address" ref 6749 6759 6763 inc parameter fixed bin(18,0) array dcl 6869 in procedure "make_both_addressable" ref 6862 6880 6890 inc 003736 automatic fixed bin(18,0) dcl 5866 in procedure "emit_inst" set ref 5878* 5881* inc 004034 automatic fixed bin(18,0) array dcl 6377 in procedure "emit_eis" set ref 6406* 6412* 6465* 6467 6467 6471 6472 incr parameter fixed bin(18,0) dcl 5910 ref 5905 5912 incre parameter fixed bin(18,0) dcl 10207 in procedure "bump_count" ref 10201 10213 10216 incre parameter fixed bin(18,0) dcl 10226 in procedure "drop_count" ref 10220 10236 10238 10245 10247 increment 0(04) based fixed bin(13,0) array level 2 in structure "machine_instruction" packed packed unaligned dcl 2765 in procedure "interpreter" set ref 5878 6406 increment 0(04) 000110 automatic fixed bin(13,0) level 2 in structure "inst" packed packed unaligned dcl 6009 in procedure "emit_c_a_const" set ref 6021 increment 0(04) 000026 external static fixed bin(13,0) array level 2 in structure "fort_opt_macros_$single_inst" packed packed unaligned dcl 2610 in procedure "interpreter" ref 5897 5967 5967 5971 ind_to_a 000531 constant fixed bin(18,0) initial array dcl 25-16 ref 9031 ind_word based bit(36) dcl 2712 set ref 11641* index 000122 automatic fixed bin(18,0) dcl 13717 in procedure "list_initialize_symbol" set ref 13740* 13786* 13786 13803 13808 13813 13818 index builtin function dcl 645 in procedure "code_generator" ref 4636 6208 13937 13987 index parameter fixed bin(18,0) dcl 8624 in procedure "flush_ref" set ref 8617 8628* 8629 index 007056 automatic fixed bin(18,0) dcl 13596 in procedure "initialize_symbol" set ref 13620* 13667 13670* 13670 13680 13684 13688 13692 index_data 002047 automatic structure level 1 unaligned dcl 2748 set ref 2858* index_regs 41 based structure array level 3 in structure "loop_state" dcl 9806 in procedure "leave_loop" index_regs 41 based structure array level 3 in structure "loop_state" dcl 2716 in procedure "interpreter" ref 9914 index_regs 41 004574 automatic structure array level 3 in structure "new_state" dcl 9514 in procedure "merge_state" index_regs 41 based structure array level 3 in structure "loop_state" dcl 9839 in procedure "enter_loop" index_regs 41 001511 automatic structure array level 3 in structure "current_ms" dcl 2714 in procedure "interpreter" set ref 4704* 8028* 8112* 8206* 9646 9646 9914* index_regs 41 parameter structure array level 3 in structure "existing_state" dcl 9514 in procedure "merge_state" index_regs 41 parameter structure array level 3 in structure "affected_ms" dcl 10301 in procedure "drop_all_ms_ref_counts" index_regs 41 based structure array level 3 in structure "machine_state" dcl 1-620 in procedure "fort_optimizing_cg" indicators 0(02) 000024 external static bit(1) array level 3 packed packed unaligned dcl 2578 ref 6091 6137 6204 indicators_valid 37 parameter fixed bin(18,0) level 3 in structure "existing_state" dcl 9514 in procedure "merge_state" set ref 9641 9641* indicators_valid 37 001511 automatic fixed bin(18,0) level 3 in structure "current_ms" dcl 2714 in procedure "interpreter" set ref 3281* 3530 3879 3882* 3915* 4410 4427* 4429* 4658* 6204* 6208* 6212* 8050* 8120* 8218* 8282* 8438* 8480 8484* 8486* 8801* 9012* 9041* 9201 9401 9401 9401 9404 9404 9431* indicators_valid 37 004574 automatic fixed bin(18,0) level 3 in structure "new_state" dcl 9514 in procedure "merge_state" set ref 9641 indp 004324 automatic pointer dcl 8455 in procedure "compare_index" set ref 8461* 8478* indp 004344 automatic pointer dcl 8504 in procedure "increment_index" set ref 8509* 8517* 8529 induction_var 004322 automatic fixed bin(18,0) dcl 8452 in procedure "compare_index" set ref 8460* 8461 induction_var 26 based pointer level 2 in structure "loop" packed packed unaligned dcl 2-100 in procedure "fort_optimizing_cg" ref 4691 10126 12317 12473 induction_var 004340 automatic fixed bin(18,0) dcl 8496 in procedure "increment_index" set ref 8508* 8509 8529* info 15 based structure level 2 packed packed unaligned dcl 2-46 inhibit 0(28) based bit(1) array level 2 packed packed unaligned dcl 2758 set ref 3000 init 0(24) based bit(1) level 3 packed packed unaligned dcl 21-23 set ref 2252* init_auto_to_zero 000253 automatic bit(1) dcl 505 set ref 845* 2932 init_info based structure level 1 dcl 28-30 init_pt 007214 automatic pointer dcl 14111 in procedure "initialize_common" set ref 14145* 14154 14154 14161* init_pt parameter pointer dcl 13703 in procedure "list_initialize_symbol" set ref 13700 13827 13828 13829* 13829 13831 13832 13835 13839 13843 13848 13853* 13853 13853 init_pt parameter pointer dcl 13593 in procedure "initialize_symbol" ref 13590 13619 init_val 007216 automatic fixed bin(18,0) dcl 14112 set ref 14147* 14153* 14158* 14166 14172 14178 14180 initial 000127 automatic structure level 1 dcl 13720 in procedure "list_initialize_symbol" initial 007063 automatic structure level 1 dcl 13598 in procedure "initialize_symbol" initial 13(07) based fixed bin(18,0) level 2 in structure "symbol" packed packed unsigned unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 1029 1029 1126* 1394 1421 1550* 1752 3576 4317 4319 6332 6688 6694 10618 27-290 13649 13655 13771 13776 13922 14161 initial_in_polish based structure level 1 dcl 13725 in procedure "list_initialize_symbol" initial_in_polish based structure level 1 dcl 13603 in procedure "initialize_symbol" initialed 0(29) based bit(1) level 4 in structure "header" packed packed unaligned dcl 1-436 in procedure "fort_optimizing_cg" set ref 1199 1270 1332 1851 1851 2252 13570 13940 14132 14136* 14140 14149 initialed 0(29) based bit(1) level 4 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 1571 13545 13578 inp 006254 automatic pointer dcl 12459 in procedure "propagate_and_eliminate_assignment" set ref 12508* 12509 12511 12519 12522 inp 000116 automatic pointer dcl 7943 in procedure "get_usage_count" set ref 7960* 7960* 7961 7963* 7970 inp 006550 automatic pointer dcl 27-241 in procedure "disconnect_temporary" set ref 27-249* 27-251 27-252 27-255 27-256* 27-256 27-268 27-269 27-273 27-275 input 005772 automatic pointer dcl 11847 set ref 11855* 11855* 11856 11856 11856 11858 11858* 11860 input_to based structure level 1 dcl 2-87 set ref 27-94 27-94 insert_operator 14(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 2-46 set ref 12226 12226* 12375 12375* 12482 12540 12540* 27-144* 27-149* insert_statement 14 based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 2-46 set ref 27-143* 27-147* inst 000110 automatic structure level 1 dcl 6009 in procedure "emit_c_a_const" set ref 6014* 6017 inst 003764 automatic structure level 1 dcl 6055 in procedure "emit_operator_call" set ref 6060* 6064 inst parameter structure level 1 dcl 6075 in procedure "put_word" ref 6069 6101 6150 inst_address 001472 automatic structure level 1 dcl 2685 in procedure "interpreter" set ref 4145* 4148 4148 4154 4154 inst_address 000104 automatic structure level 1 dcl 7376 in procedure "base_man_load_large_base" set ref 7444* 7447 7447 inst_address 004106 automatic structure level 1 dcl 6854 in procedure "c_a_tag" set ref 6856* 6858 inst_address 000100 automatic structure level 1 dcl 6830 in procedure "c_a_18" set ref 6837* 6844 inst_address 004134 automatic structure level 1 dcl 7185 in procedure "base_man_load_pr" set ref 7243* 7253 7253 7262 7262 7264 7264 7272 7272 7281 7281 inst_address 000110 automatic structure level 1 packed packed unaligned dcl 7473 in procedure "base_man_load_large_base_no_flush" set ref 7475* 7478 7478 inst_address 000123 automatic structure level 1 packed packed unaligned dcl 7586 in procedure "base_man_store_temp" set ref 7593* 7600 7600 7627 7627 7643 7643 7655 7655 inst_address 000101 automatic structure level 1 dcl 6778 in procedure "c_a" set ref 6781* 6818 inst_number 004542 automatic fixed bin(18,0) dcl 9339 set ref 9346* 9348* 9353* inst_op_code parameter fixed bin(18,0) dcl 6177 ref 6172 6187 inst_pos 004040 automatic fixed bin(18,0) dcl 6395 set ref 6434* 6444 6446 instruction based fixed bin(17,0) array level 2 in structure "forward_refs" packed packed unaligned dcl 568 in procedure "code_generator" set ref 728 6338* instruction based structure array level 1 dcl 2808 in procedure "interpreter" int_image based fixed bin(35,0) dcl 2706 ref 4633 4824 6284 6289 8470 10586 10637 11429 int_mode 000756 constant fixed bin(4,0) initial dcl 4-106 set ref 2454 2952 4031* 4037 4630 4822 8473* 8511* 9435 10522* 11299* 11490* 11586* 11593* 12603 12701 12738 12744 12848 12854 13275* 13432* integer 10(20) based bit(1) level 5 packed packed unaligned dcl 1-844 set ref 2455* interpreter_called 0(06) based bit(1) level 4 packed packed unaligned dcl 2718 set ref 3295 3987 5236* interpreter_return 6 based label variable local level 2 dcl 2718 set ref 3297 3995 5237* invariant 004323 automatic fixed bin(18,0) dcl 8452 set ref 8462* 8463 8473* 8482* invp 004326 automatic pointer dcl 8455 set ref 8463* 8470 8470 8473 8473 ip parameter fixed bin(3,0) dcl 8139 ref 8133 8143 ipol 006566 automatic fixed bin(18,0) dcl 27-287 set ref 27-290* 27-292 27-293 iquad parameter fixed bin(18,0) dcl 11871 in procedure "reset_scan" set ref 11866 11942* 11953* iquad 000661 automatic fixed bin(18,0) dcl 2524 in procedure "interpreter" set ref 3306 3309* 4061* 4785 4785 4785 13006* 13010* 13021* is_addressable 0(14) based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 1121* 1239* 1418* 1444* 1514* 1544* 1548* 1592* 1627* 1646* 1677* 2943* 6699* is_addressable 0(14) based bit(1) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "fort_optimizing_cg" set ref 5506* 5715* 5811* is_addressable 0(14) based bit(1) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "fort_optimizing_cg" set ref 965* 4307 4440 6041 6114 6467 6552 6877 7204 7336 8044 8796 is_addressable 0(14) based bit(1) level 3 in structure "label" packed packed unaligned dcl 1-530 in procedure "fort_optimizing_cg" set ref 1144* 2485* is_addressable 0(14) based bit(1) level 3 in structure "constant" packed packed unaligned dcl 1-256 in procedure "fort_optimizing_cg" set ref 12-83* is_addressable 0(14) based bit(1) level 3 in structure "header" packed packed unaligned dcl 1-436 in procedure "fort_optimizing_cg" set ref 1357* is_addressable 0(14) based bit(1) level 3 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "fort_optimizing_cg" set ref 2927* 10626* is_addressable 0(14) based bit(1) level 3 in structure "char_constant" packed packed unaligned dcl 1-316 in procedure "fort_optimizing_cg" set ref 2911* is_string 6 based bit(1) array level 4 dcl 52 set ref 10499* 10507* item 5 002047 automatic pointer array level 3 in structure "index_data" packed packed unaligned dcl 2748 in procedure "interpreter" set ref 8351 8358* 11996 12037 item parameter pointer array level 2 in structure "item_st" packed packed unaligned dcl 12056 in procedure "sort_globals" set ref 12072 12075 12079 12080* 12080 12081* item 5 001675 automatic pointer array level 3 in structure "ptr_data" packed packed unaligned dcl 2737 in procedure "interpreter" set ref 7805 7812* 11988 12026 item_chain parameter pointer dcl 12158 ref 12155 12168 item_st 5 001675 automatic structure level 2 in structure "ptr_data" dcl 2737 in procedure "interpreter" set ref 12013* item_st 5 002047 automatic structure level 2 in structure "index_data" dcl 2748 in procedure "interpreter" set ref 12014* item_st parameter structure level 1 dcl 12056 in procedure "sort_globals" set ref 12051 itp based structure level 1 dcl 19-18 itp_list 2 002543 automatic structure array level 2 dcl 2829 set ref 4284 11627* 11641 itp_mod 0(30) based bit(6) level 2 in structure "itp" packed packed unaligned dcl 19-18 in procedure "code_generator" ref 923 927 itp_mod 2(30) 002543 automatic bit(6) array level 3 in structure "arg_list" packed packed unaligned dcl 2829 in procedure "interpreter" set ref 11632* j 000322 automatic fixed bin(18,0) dcl 534 in procedure "code_generator" set ref 728* 729 729 j 005312 automatic fixed bin(18,0) dcl 10303 in procedure "drop_all_ms_ref_counts" set ref 10312* 10313 10313* j 004356 automatic fixed bin(3,0) dcl 8543 in procedure "reserve_regs" set ref 8555* 8556* 8557 8558 8562* 8563* 8564 8565 8566 8568 j 004762 automatic fixed bin(18,0) dcl 9516 in procedure "merge_state" set ref 9563* 9564 9564 9566 9566 9567 9568 9569 9570 9571 9603* 9603* 9607 9616* 9617 9617* j 006355 automatic fixed bin(17,0) dcl 12649 in procedure "process_loop_end_lists" set ref 12662* 12664* 12664 12666 j 004250 automatic fixed bin(3,0) dcl 8195 in procedure "xr_man_add_const" set ref 8206* 8208* 8210 8218 8220 8221 8222 8227 j 006057 automatic fixed bin(17,0) dcl 12060 in procedure "sort_globals" set ref 12073* 12075 12079 12080 12083 12085 j 000101 automatic fixed bin(18,0) dcl 7887 in procedure "get_free_reg" set ref 7896* 7913* 7920* 7927 7929 j 000107 automatic fixed bin(3,0) dcl 6945 in procedure "base_man_load_any_pr" set ref 6957* 6969* 6972 6977 6979 jump_false_op constant fixed bin(18,0) initial dcl 4-197 ref 4785 jump_op constant fixed bin(18,0) initial dcl 4-197 ref 27-141 jump_true_op constant fixed bin(18,0) initial dcl 4-197 ref 4785 k 000101 automatic fixed bin(3,0) dcl 7497 in procedure "base_man_load_arg_ptr" set ref 7503* 7506* 7515* k 006060 automatic fixed bin(17,0) dcl 12060 in procedure "sort_globals" set ref 12071* 12072 12073 12080 12081 12085* k 007140 automatic fixed bin(18,0) dcl 13963 in procedure "compile_link" set ref 13987* 13989 13992 13998 14004 k 000110 automatic fixed bin(3,0) dcl 6945 in procedure "base_man_load_any_pr" set ref 6957* 6960* 6981* 6999* 7036* 7039* k 000102 automatic fixed bin(3,0) dcl 7374 in procedure "base_man_load_large_base" set ref 7389* 7390 7390 7390 7392 7392 7394 7395* 7406* 7407 7409 7414* 7418 7420* 7424 7426* 7430 7432* 7437 7437* 7440* 7440* k 004223 automatic fixed bin(3,0) dcl 8101 in procedure "xr_man_load_const" set ref 8106* 8108 8109 8112* k 000676 automatic fixed bin(18,0) dcl 2540 in procedure "interpreter" set ref 3026* 3028 3186* 3191* 3200 3206 3212 3218 3224 3230 3233 3245* 3247 3247 3249 3856* 3858 3931* 3932 3935 4115* 4116 4118 4265* 4266* 4267 4273 4274 4316* 4317 4317* 4317 4319 4353* 4358* 4359 4361 4362 4480* 4481 4481 4481 4486* 4498* 4502 4504 4508* 5052* 5057 k 000101 automatic fixed bin(3,0) dcl 7539 in procedure "base_man_load_desc_ptr" set ref 7545* 7548* 7557* l_bound 1 006754 automatic fixed bin(18,0) array level 3 in structure "descriptor" dcl 13322 in procedure "make_entry_descriptor" set ref 13403* 13415* 13417* l_bound 1 000117 automatic fixed bin(18,0) array level 3 in structure "descriptor" dcl 13173 in procedure "make_symbol_descriptor" set ref 13246* 13258* 13260* label 0(18) based fixed bin(18,0) level 2 in structure "opt_statement" packed packed unsigned unaligned dcl 2-176 in procedure "fort_optimizing_cg" set ref 4079 4081 11966 11970* label based structure level 1 dcl 1-530 in procedure "fort_optimizing_cg" set ref 2480 2480 label_node 000744 constant fixed bin(4,0) initial dcl 4-87 set ref 2480* large_address 0(20) based bit(1) level 3 in structure "array_ref" packed packed unaligned dcl 1-155 in procedure "fort_optimizing_cg" set ref 10660* 10660 large_address 0(20) based bit(1) level 3 in structure "temporary" packed packed unaligned dcl 1-1005 in procedure "fort_optimizing_cg" set ref 5715 6646 7598 large_address 0(20) based bit(1) level 3 in structure "node" packed packed unaligned dcl 1-63 in procedure "fort_optimizing_cg" set ref 964* 6725 6759 large_address 0(20) based bit(1) level 3 in structure "symbol" packed packed unaligned dcl 1-844 in procedure "fort_optimizing_cg" set ref 6681 7115 10631 10660 13479 13490 13625 13748 13927 large_base_reg 000124 automatic fixed bin(3,0) dcl 7587 set ref 7607* 7608 7611* 7618 7618* 7623 7625 7626 large_offset 0(34) based bit(1) level 3 packed packed unaligned dcl 1-155 ref 6576 last parameter fixed bin(18,0) dcl 7882 in procedure "get_free_reg" ref 7877 7899 last 006436 automatic pointer dcl 27-71 in procedure "chain_input" set ref 27-82* 27-83 last 1 based pointer level 2 in structure "primary" packed packed unaligned dcl 2-234 in procedure "fort_optimizing_cg" set ref 12400* 12404* last 006552 automatic pointer dcl 27-241 in procedure "disconnect_temporary" set ref 27-247* 27-255* 27-266 27-268 27-269 last 006667 automatic fixed bin(18,0) dcl 12989 in procedure "start_subprogram" set ref 13040* 13043 last 13(18) based fixed bin(18,0) array level 3 in structure "subprogram" packed packed unsigned unaligned dcl 1-753 in procedure "fort_optimizing_cg" set ref 1204 1206 1207* 1276 1278 1279* 1306 1308 1309* 1369 1371 1372* 1604 1606 1607* last_assigned_mode constant fixed bin(4,0) initial dcl 4-106 ref 3501 last_auto_loc 000324 automatic fixed bin(18,0) dcl 549 set ref 1013 1047* 1095* 1180 1180* 1180 1184 1186* 1186 1264 1265* 1265 1448 1449* 1449 1453 1458 1459* 1459 1469 1469* 1469 1472 1473* 1473 1474 1650* 1650 1652* 1653* 1653 1654 1681* 1681 1683* 1684 1685* 1685 1686 1698 1702* 1943* 1943 2932 5442 5495 5499* 13025* 13025 13025 13026 13027* 13028* 13028 13030 14252 last_base 000744 constant fixed bin(18,0) initial dcl 2599 set ref 2860 3223 4265* 4353* 6959 6981* 6999* 7026* 7039* 7297 7389 7409 7418 7424 7430 7440* 7505 7515* 7547 7557* 7608 7637* 7679 7700 7761 7776 8595 8713 9556 9692 9773 9814 9849 9881 9903 9982 10274 10334 last_c 006366 automatic pointer dcl 12651 set ref 12665* 12669 last_constant 101 based fixed bin(18,0) array level 3 dcl 47 set ref 12-91 12-93* last_def 000271 automatic bit(18) dcl 531 set ref 13894* 13905 14211 14211 14215 14236* 14268 14269 last_dynamic_temp 163 004574 automatic fixed bin(18,0) level 3 in structure "new_state" dcl 9514 in procedure "merge_state" set ref 9677 last_dynamic_temp 163 001511 automatic fixed bin(18,0) level 3 in structure "current_ms" dcl 2714 in procedure "interpreter" set ref 3233 3233* 4876* 5850* 11224 last_dynamic_temp 163 parameter fixed bin(18,0) level 3 in structure "existing_state" dcl 9514 in procedure "merge_state" set ref 9677 9677* last_entry_name 76 based fixed bin(18,0) level 2 dcl 47 ref 11786 last_fu 006004 automatic pointer dcl 11877 set ref 11908* 11911 last_header 000214 automatic pointer initial dcl 496 set ref 496* 2008 2009* last_index 000750 constant fixed bin(18,0) initial dcl 2599 set ref 2861 3211 4504 4704* 8016 8028* 8112* 8171 8206* 8242 8586 8682 9539 9687 9781 9818 9853 9885 9908 9966 10268 10323 last_label 4(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 set ref 2489 2491 2492* last_listp 000144 automatic pointer dcl 2234 set ref 2270* 2271 2272 last_namelist 000211 automatic fixed bin(18,0) dcl 495 set ref 668* 1424 1426 1427* last_o 006316 automatic pointer dcl 12563 set ref 12581* 12582 12583 12585 last_operator 006357 automatic fixed bin(18,0) dcl 12650 in procedure "process_loop_end_lists" set ref 12658* 12659* last_operator parameter fixed bin(18,0) dcl 12559 in procedure "insert_operator_after" ref 12556 12581 12584 last_pos 000202 automatic fixed bin(18,0) dcl 488 set ref 714* 798 last_pr_locked_for_pl1_ops_arg 002046 automatic fixed bin(3,0) dcl 2746 set ref 2859* 6633 6633 6730 6730 7297* 8582* last_quad 10(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 ref 11942 13006 last_statement 13(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 2-46 ref 12657 27-137 last_subprogram 73 based fixed bin(18,0) level 2 dcl 47 ref 2913 last_symbol 3(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 1-753 set ref 2459 2460* 13298 13299* last_unit 14 based pointer level 2 packed packed unaligned dcl 2-100 ref 12654 27-187 lbl 005346 automatic pointer dcl 10398 in procedure "alloc_label" set ref 10401* 10403 10403 10406 10439 lbl 006020 automatic fixed bin(18,0) dcl 11964 in procedure "get_label" set ref 11966* 11968 11970* 11971 11974 lbl parameter fixed bin(18,0) dcl 9455 in procedure "save_state" ref 9450 9458 lbl 000726 automatic pointer dcl 2546 in procedure "interpreter" set ref 4464* 4470 4470 4473 lbound builtin function dcl 645 ref 9646 9660 lca 000424 constant fixed bin(18,0) initial dcl 25-16 set ref 12810* 12823* lchain based structure level 1 dcl 2-94 set ref 12669 12670 lcq constant bit(10) initial dcl 6234 ref 6296 6305 ldq constant bit(10) initial dcl 6234 ref 6296 6305 left based bit(18) array level 2 in structure "reloc_halfs" packed packed unaligned dcl 562 in procedure "code_generator" set ref 923* 927* 2124* 2241* 2243* 2273* 14266* left 000663 automatic fixed bin(18,0) dcl 2527 in procedure "interpreter" set ref 3013* 3047 3053* 3058* 3058* 3070 3088 3090* 3106 3114 3119 3122 3126* 3132* 3135 3138 3302 3341* 3346* 3358 3666 3676 3682 3688 3711 3756* 3765* 3799* 3803* 3807* 3862 3862 3888* 3896* 3920 3925 3931 3932 3965 4229 4235* 4239* 4239* 4388 4466 4466 4532* 4536* 4588 4643 4842 4851 4868 5081 6418 10487 10493* 10494 left based fixed bin(17,0) level 2 in structure "half" packed packed unaligned dcl 2825 in procedure "interpreter" ref 6264 6278 6292 left based fixed bin(17,0) array level 2 in structure "macro_instruction" packed packed unaligned dcl 2758 in procedure "interpreter" set ref 3013 3132 3337 10493 10509 left based fixed bin(17,0) array level 2 in structure "text_halfs" packed packed unaligned dcl 558 in procedure "code_generator" set ref 729* 729 4937* 4948* 4952* 4994* 5012* 5057* 5934* 5971* 5971 6108* 6166* 6166 6266* 6278* 6312* 6325* 6342* 6342 6472* 6472 10461* 14260* 14268* 14278 left_rel 0(12) based bit(6) array level 2 packed packed unaligned dcl 2819 set ref 4116* 4949* 4953* 4995* 5013* 5060* 5990* 6019* 6152* 6269* 6280* 6314* 6457* 7043* 7046* 7122* 10462* 10473* left_shift_chain 40 based pointer level 2 packed packed unaligned dcl 2-100 set ref 12363 12416 12417* len parameter fixed bin(18,0) dcl 14112 in procedure "initialize_common" ref 14108 14127 len 006653 automatic fixed bin(18,0) dcl 12843 in procedure "lhs_fld" set ref 12877* 12878 12878 12880 12894* 12894 12896 12905 12905 12911 12919* 12919* 12953* 12956 len 006631 automatic fixed bin(18,0) dcl 12734 in procedure "rhs_fld" set ref 12761* 12762 12762 12764 12781* 12781 12782 12788 12793* 12793* 12798 12818 len parameter fixed bin(18,0) dcl 12717 in procedure "generate_mask" ref 12712 12721 len 004030 automatic fixed bin(18,0) array dcl 6375 in procedure "emit_eis" set ref 6424* 6424 6455 6515* 6521* 6525* 6529 6529* len 005412 automatic pointer dcl 10537 in procedure "optimized_subscript" set ref 10583* 10584 10586 length 7 based fixed bin(24,0) level 2 in structure "array_ref" dcl 1-155 in procedure "fort_optimizing_cg" set ref 2932* 2934* 10593* 10597* 10604* 10608* 11164 13143 13145 length 0(24) based bit(12) array level 2 in structure "descriptor" packed packed unaligned dcl 6380 in procedure "emit_eis" set ref 6418 6453* 6455* 6509 6525 length builtin function dcl 13967 in procedure "compile_link" ref 13969 13998 length 1 based fixed bin(24,0) level 2 in structure "create_entry" dcl 21-23 in procedure "code_generator" set ref 2253* length based fixed bin(35,0) level 2 in structure "create_init_entry" dcl 21-61 in procedure "code_generator" set ref 13581* 13828* 13831* 13835 13839 13843 13848 13853 length 12 based fixed bin(24,0) level 2 in structure "temporary" dcl 1-1005 in procedure "fort_optimizing_cg" set ref 5394* 5570 5594* 5594 5596* 5626 5634* 5837 5838 11429* 11437* 13150 13152 length 005614 automatic pointer dcl 11419 in procedure "assign_length_to_cat_result" set ref 11422* 11424 11429 length builtin function dcl 1926 in procedure "create_storage_entry" ref 2124 2241 2243 2273 length builtin function dcl 2848 in procedure "interpreter" ref 3381 3400 length 6 based fixed bin(24,0) level 2 in structure "header" dcl 1-436 in procedure "fort_optimizing_cg" set ref 1344 1345 1818 1820 1822 1830 1832 1834 1869 2017 2017 2022 2022 2022 2022 2027 2027 2027* 2027 2103 2129* 2253 length parameter fixed bin(17,0) dcl 13-12 in procedure "create_node" ref 13-10 13-20 13-23 13-24 length builtin function dcl 13188 in procedure "make_symbol_descriptor" ref 13291 length builtin function dcl 8544 in procedure "reserve_regs" ref 8551 length builtin function dcl 14068 in procedure "name_assign" ref 14072 14079 14089 length 4 based fixed bin(18,0) level 2 in structure "char_constant" packed packed unsigned unaligned dcl 1-316 in procedure "fort_optimizing_cg" set ref 752 895 900 902 2913* 2934 4043 4598 4601 4604 4611 4614 4617 4835 6252 12706 13131 13688 13692 13843 13848 lib 000323 automatic fixed bin(18,0) dcl 534 set ref 748* 748* 749* lib_list_ptr 000222 automatic pointer dcl 498 set ref 741* 744 745 751 752 lib_pos 000201 automatic fixed bin(18,0) dcl 488 set ref 667* 740* 741 742 781 781 781 lib_pt 000164 automatic pointer dcl 486 set ref 749* 750 755 lib_reloc_ptr 000234 automatic pointer dcl 499 set ref 742* 753 library based structure level 1 dcl 1-605 limit 1 000127 automatic fixed bin(35,0) level 2 in structure "initial" dcl 13720 in procedure "list_initialize_symbol" set ref 13783* 13785* 13786 limit 1 007063 automatic fixed bin(18,0) level 2 in structure "initial" dcl 13598 in procedure "initialize_symbol" set ref 13663* 13665 limit parameter fixed bin(18,0) dcl 2285 in procedure "relocate" ref 2280 2343 2343 2343 limit 1 based fixed bin(35,0) level 2 in structure "initial_in_polish" dcl 13725 in procedure "list_initialize_symbol" ref 13783 limit 1 based fixed bin(18,0) level 2 in structure "initial_in_polish" dcl 13603 in procedure "initialize_symbol" ref 13663 limit 007061 automatic fixed bin(18,0) dcl 13596 in procedure "initialize_symbol" set ref 13656* 13665* 13665 13667 link based structure level 1 dcl 15-11 link_base 000216 automatic pointer dcl 498 set ref 761* 792 13470 13479 13481 13490 13492 13501* 13508 13880 13881 13882 13883 14021 link_base_ptr 000130 automatic pointer level 2 dcl 58 set ref 792* link_begin 6 based bit(18) level 2 packed packed unaligned dcl 15-52 set ref 13881* link_pos 000172 automatic fixed bin(18,0) dcl 488 in procedure "code_generator" set ref 667* 768 797 817 1697* 1703* 1709 1713* 1713 1715* 1715 1717* 1717 1717 1718 1725 1735 1744 1752* 1767* 1770* 1770 1772 1874 1875* 1875 1876 2187 13882 link_pos parameter fixed bin(15,0) dcl 13953 in procedure "compile_link" ref 13950 14021 14022 14038 link_ptr 007132 automatic pointer dcl 13960 set ref 14021* 14038 14039 14042 link_reloc_base 000230 automatic pointer dcl 499 set ref 762* 793 13886 14022 link_reloc_base_ptr 2 000130 automatic pointer level 2 dcl 58 set ref 793* link_reloc_ptr 007136 automatic pointer dcl 13960 set ref 14022* 14040 14043 linkage_length 5(18) based bit(18) level 2 packed packed unaligned dcl 16-10 set ref 817* linkage_offset 5 based bit(18) level 2 packed packed unaligned dcl 16-10 set ref 816* linkage_pad 000325 automatic fixed bin(18,0) dcl 551 set ref 1104* 1172 1172* 1172 1174 1176* 1176 1256 1258* 1258 1697 1941* 1941 2119 2120* 2120 2155* 2155 linkage_section_lng 6(18) based bit(18) level 2 packed packed unaligned dcl 15-52 set ref 13882* linkrel 000176 automatic fixed bin(18,0) dcl 488 set ref 760* 761 762 768 816 818 list 113(10) based bit(1) level 5 packed packed unaligned dcl 47 ref 675 list_head parameter pointer dcl 12273 in procedure "alloc_inner" set ref 12270 12281 12290 12291* list_head 006152 automatic pointer dcl 12194 in procedure "allocate" set ref 12241* 12242* 12243 12248* 12249* 12250 list_init_info based structure level 1 dcl 28-41 list_size 2(18) based fixed bin(18,0) level 2 packed packed unsigned unaligned dcl 28-41 set ref 14155* listing 113(07) based structure level 4 packed packed unaligned dcl 47 listp 000102 automatic pointer dcl 1922 set ref 1936 1936 1937 1939 1939 1948 1948 1959 2122 2153 2154 2160 2166 2186* 2187 2187 2187 2189 2236* 2240 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2256 2259 llr_18_instruction 000340 constant bit(36) initial dcl 7069 ref 7087 lng 1(18) based fixed bin(17,0) array level 3 packed packed unaligned dcl 574 set ref 752* load_base 000570 constant fixed bin(18,0) initial array dcl 25-16 set ref 6985 7013 7030 7049 7090* 7103* 7230 7235 7346 7447 7478 7522 7564 load_ind 000676 constant fixed bin(18,0) initial dcl 25-16 set ref 9440* load_inst 000556 constant fixed bin(18,0) initial array dcl 25-16 set ref 4210 4221 8799* 9231 10931* 10933* 10962* 10983* 11003* 11015* 11482 12933* 12936* 12952* 12955* 12970* 12974* load_opnd 004265 automatic fixed bin(18,0) dcl 8266 set ref 8269* 8288* 8292* load_p 004260 automatic pointer dcl 8261 set ref 8268* 8269 8277 8279* 8286 load_packed_base 000441 constant fixed bin(18,0) initial array dcl 25-16 set ref 7082* 7100* 7123* load_preg_op constant fixed bin(18,0) initial dcl 4-197 ref 12223 load_segment_num 000433 constant fixed bin(18,0) initial array dcl 25-16 set ref 7091* 7104* load_xreg_op constant fixed bin(18,0) initial dcl 4-197 ref 12214 loc 000165 automatic fixed bin(18,0) dcl 2290 in procedure "relocate" set ref 2292* 2300 2307* 2311* 2318* 2322* 2325* 2325 2325 2329 2341 2343 loc 004076 automatic fixed bin(18,0) dcl 6757 in procedure "increment_address" set ref 6763* 6765 loc 000127 automatic fixed bin(18,0) dcl 5489 in procedure "create_temp" set ref 5495* 5497 5499 5521* loc 000133 automatic fixed bin(18,0) dcl 1080 in procedure "assign_storage" set ref 1343* 1350 1578* 1589 loc 000102 automatic fixed bin(18,0) dcl 1796 in procedure "alloc_external" set ref 1814* 1857 1874* 1879 loc 000100 automatic fixed bin(18,0) dcl 955 in procedure "set_address_offset" set ref 963* 967 local 001675 automatic fixed bin(17,0) level 2 in structure "ptr_data" dcl 2737 in procedure "interpreter" set ref 7155* 7155 7163* 7163 7166* 7166 7305 7787* 7787 7788 8720* 8720 9572* 9572 9575* 9575 9701* 9790* 11985* local 002047 automatic fixed bin(17,0) level 2 in structure "index_data" dcl 2748 in procedure "interpreter" set ref 8073* 8073 8088* 8088 8224 8370* 8370 8371 8688* 8688 9547* 9547 9552* 9552 9701* 9790* 11993* location 1 based fixed bin(18,0) level 3 in structure "constant" packed packed unsigned unaligned dcl 1-256 in procedure "fort_optimizing_cg" set ref 871* location 005416 automatic fixed bin(17,0) level 2 in structure "constant_address" packed packed unaligned dcl 10540 in procedure "optimized_subscript" set ref 10649* 10650 location 000124 automatic fixed bin(18,0) dcl 2095 in procedure "create_storage_entry" set ref 2119* 2125 2131 2143 2183* 2186 2189* 2190 location 1 based fixed bin(18,0) level 3 in structure "label" packed packed unsigned unaligned dcl 1-530 in procedure "fort_optimizing_cg" set ref 729 1417* 3729 10385* 14256 14281 location 5 based fixed bin(24,0) level 2 in structure "symbol" dcl 1-844 in procedure "fort_optimizing_cg" set ref 1460* 1460 1472* 1480* 1480 1505 1540* 1589* 1632* 1805 1898* 1901* 4168 4168 4215 4215 6683 7115 10631 11481* 13481 13492 13625 13744 13748 13927 location based fixed bin(18,0) level 2 in structure "create_entry" packed packed unsigned unaligned dcl 21-23 in procedure "code_generator" set ref 2240* location 5 based bit(18) level 2 in structure "opt_statement" packed packed unaligned dcl 2-176 in procedure "fort_optimizing_cg" set ref 4084* location 5 based fixed bin(24,0) level 2 in structure "temporary" dcl 1-1005 in procedure "fort_optimizing_cg" set ref 5585* 5585 6646 7611 7618 7642 7654 location 1 based fixed bin(18,0) level 3 in structure "char_constant" packed packed unsigned unaligned dcl 1-316 in procedure "fort_optimizing_cg" set ref 751 901* 2919* 10618 location 5 based fixed bin(24,0) level 2 in structure "header" dcl 1-436 in procedure "fort_optimizing_cg" set ref 1174* 1184* 1256* 1264* 1268 1302* 1350* 1814 1898 1901 1933 1937 2119* 2122* 2130* 2240 13470 13937 13940 location 5 based fixed bin(24,0) level 2 in structure "node" dcl 1-63 in procedure "fort_optimizing_cg" set ref 944 967* 1735* 1735 1744* 1744 2339 6681 6683 6738 6763 6765* lock_it parameter bit(1) dcl 7178 ref 7171 7293 locked 1 001675 automatic fixed bin(17,0) level 2 in structure "ptr_data" dcl 2737 in procedure "interpreter" set ref 7702* 7702 7703 8582* 11985* locked 1 002047 automatic fixed bin(17,0) level 2 in structure "index_data" dcl 2748 in procedure "interpreter" set ref 8308* 8308 8309 8582* 11993* locn parameter fixed bin(18,0) dcl 2285 set ref 2280 2292 2329* logical_mode 000752 constant fixed bin(4,0) initial dcl 4-106 set ref 2892* long_profile 000352 constant fixed bin(14,0) initial dcl 2650 in procedure "interpreter" set ref 4993* 5011* 10457* long_profile 12(02) based bit(1) level 3 in structure "subprogram" packed packed unaligned dcl 1-753 in procedure "fort_optimizing_cg" ref 847 long_profile_entry based structure level 1 dcl 11-12 ref 1713 10469 long_profile_header based structure level 1 dcl 11-4 set ref 1043 1712 1713 13509* loop 5 based pointer level 2 in structure "flow_unit" packed packed unaligned dcl 2-46 in procedure "fort_optimizing_cg" ref 4067 4072 4663 4722 11888 11918 loop based structure level 1 dcl 2-100 in procedure "fort_optimizing_cg" loop_end_chain 7 based pointer level 2 packed packed unaligned dcl 2-46 set ref 12663 12670 12671* 27-192 27-194* loop_end_fu_pos 3(18) based fixed bin(17,0) level 2 packed packed unaligned dcl 1-1005 set ref 27-205* loop_end_op 000634 constant fixed bin(18,0) initial dcl 4-197 set ref 12659* loop_ref_count 4(18) based fixed bin(17,0) level 2 packed packed unaligned dcl 1-63 set ref 8349 8361* 8361 11997* 12100 12100 loop_state based structure level 1 dcl 9839 in procedure "enter_loop" loop_state based structure level 1 dcl 9806 in procedure "leave_loop" loop_state based structure level 1 dcl 2716 in procedure "interpreter" loop_vector based pointer array level 2 packed packed unaligned dcl 2699 ref 9932 11937 11946 12654 13003 13010 13015 13015 13065 loop_vector_p 55 based pointer level 2 in structure "subprogram" packed packed unaligned dcl 1-753 in procedure "fort_optimizing_cg" ref 12996 loop_vector_p 001450 automatic pointer dcl 2559 in procedure "interpreter" set ref 9932 11937 11946 12654 12996* 13003 13010 13015 13015 13065 loop_vector_st based structure level 1 dcl 2699 looping 000112 automatic bit(1) packed unaligned dcl 1974 set ref 2059* 2060 2062* 2064* 2181* 2184 2190* lower 0(09) based bit(1) array level 3 packed packed unaligned dcl 1-383 ref 2407 2428 10727 10785 10857 10864 10960 13258 13415 lower_bound 5 based fixed bin(24,0) array level 3 dcl 1-383 ref 2377 2425 2428 10729 10780 10790 10857 10864 10866 10866 10962 10972 10994 11003 11007 11015 11021 13246 13258 13403 13415 lowest_count 000104 automatic fixed bin(18,0) dcl 7887 set ref 7897* 7909 7911* 7916 lp parameter pointer dcl 9835 in procedure "enter_loop" ref 9828 9843 9845 lp 006250 automatic pointer dcl 12455 in procedure "propagate_and_eliminate_assignment" set ref 12463* 12464 12473 12473 lp 006212 automatic pointer dcl 12307 in procedure "check_comparisons_and_increments" set ref 12352* 12352 12352* 12355 12357 12363 12385* 12397 12416 12417 lp defined bit(3) dcl 596 in procedure "code_generator" ref 923 1175 1230 1353 1539 1585 1629 4307 6734 6788 6796 7380 7732 lp parameter pointer dcl 10139 in procedure "find_range" ref 10134 10149 lp 005122 automatic pointer dcl 9929 in procedure "cleanup_loop_state_nodes" set ref 9932* 9933 9935 9936 9937 lp 006702 automatic pointer dcl 13057 in procedure "reset_subprogram" set ref 13065* 13067 lp parameter pointer dcl 27-179 in procedure "put_in_loop_end" ref 27-177 27-187 lp parameter pointer dcl 12616 in procedure "is_invariant_in" ref 12613 12623 12628 12632 lp parameter pointer dcl 10068 in procedure "assign" ref 10065 10072 10072 10074 lp 005070 automatic pointer dcl 9870 in procedure "refresh_global_bits" set ref 9875* 9877 9877 9877* lp 006114 automatic pointer dcl 12117 in procedure "ok_to_allocate" set ref 12129* 12132 12132 12136 12136 12139 12139* 12139 12143 12144* 12144 12145 12149* 12149 lp 006154 automatic pointer dcl 12194 in procedure "allocate" set ref 12236* 12241 12242 12243 12244 12248 12249 12250 12253 12253* 12253 12257 12258* 12258 12259 12263* 12263 lp_msp parameter pointer dcl 9835 in procedure "enter_loop" set ref 9828 9845* lp_msp parameter pointer dcl 9804 in procedure "leave_loop" ref 9798 9810 lp_msp 000654 automatic pointer dcl 2519 in procedure "interpreter" set ref 4012* 4073* 4074* 4785 7673 7680 7680 7680 8244 8244 9901 9904 9904 9909 9914 9919 9920 9959 9971 9971 9983 9983 9983 9983 9983 12991* lreg 004032 automatic bit(6) array dcl 6376 set ref 6407* 6425* 6425 6446 6453 6453 6518* 6520* 6529* 6534 lrl constant fixed bin(18,0) initial dcl 25-16 ref 4151 lrs 000426 constant fixed bin(18,0) initial dcl 25-16 set ref 12937* 12956* 12975* ls_op 006234 automatic fixed bin(18,0) dcl 12308 set ref 12375* 12377 12379* 12381* lsc 006222 automatic pointer dcl 12307 set ref 12363* 12364 12365 12367* 12367 12414* 12415 12416 12417 12420 lsp 006224 automatic pointer dcl 12307 set ref 12377* 12380 12381 12385 12385 12408 12415 12420* 12436 12441 ltp 000102 automatic pointer dcl 5616 set ref 5626* 5627 5629 5629 5631 5631 5632* ltrim builtin function dcl 13-17 in procedure "create_node" ref 13-29 13-29 ltrim builtin function dcl 12-28 in procedure "create_constant" ref 12-45 12-45 ltrim builtin function dcl 645 in procedure "code_generator" ref 1841 1841 1844 1844 2022 2022 2343 2343 27-54 27-54 27-122 27-122 lused 000103 automatic fixed bin(18,0) dcl 7887 set ref 7912* 7916 7919* lxl0 constant fixed bin(18,0) initial dcl 25-16 set ref 8047 8292 12929* 12948* 12965* lxl1 constant fixed bin(18,0) initial dcl 25-16 set ref 12966* m 007220 automatic fixed bin(18,0) dcl 14113 set ref 14152* 14154* 14155 14180 mac 004343 automatic fixed bin(18,0) dcl 8502 in procedure "increment_index" set ref 8521* 8523* 8525* mac 005502 automatic fixed bin(18,0) dcl 11062 in procedure "add" set ref 11064* 11073* 11079* 11081* mac_base 000640 automatic pointer dcl 2511 set ref 2972* 3000 3012 3013 3014 3037 3078 3083 3083 3101 3117 3132 3157 3316 3334 3337 3381 3383 3400 3409 3413 3421 3456 3458 3495 3507 3513 3528 3533 3539 3545 3551 3558 3564 3573 3579 3584 3590 3595 3633 3637 3678 3685 3689 3689 3690 3746 3793 3817 3820 3872 3888 3893 3913 4029 4034 4280 4401 4585 4655 4887 4896 4902 4907 4913 4920 4931 5073 5272 5327 5868 5870 5870 5871 5878 5879 5881 6404 6406 6418 6435 6436 6509 6525 10488 10493 10500 10508 10509 10509 mac_no parameter fixed bin(18,0) dcl 6032 ref 6027 6038 mac_num parameter fixed bin(18,0) dcl 6006 in procedure "emit_c_a_const" ref 6001 6014 mac_num 000100 automatic fixed bin(18,0) dcl 6035 in procedure "emit_temp_store" set ref 6038* 6044* mac_num parameter fixed bin(18,0) dcl 5984 in procedure "emit_c_a_var" ref 5978 5997 mac_num parameter fixed bin(18,0) dcl 5893 in procedure "emit_single" ref 5888 5897 5899 5905 5915 mac_num parameter fixed bin(18,0) dcl 5944 in procedure "emit_zero" ref 5939 5949 mac_num parameter fixed bin(18,0) dcl 5959 in procedure "emit_c_a" ref 5954 5965 5967 5967 5971 mac_num parameter fixed bin(18,0) dcl 5926 in procedure "emit_with_tag" ref 5921 5932 mac_num parameter fixed bin(18,0) dcl 5227 in procedure "interpreter_proc" ref 5205 5232 mac_proc 003664 automatic fixed bin(18,0) dcl 5254 set ref 5256* 5258* 5272 machine_instruction based structure array level 1 dcl 2765 set ref 3083 3083 3685 3690 5871 5881 6435 machine_state based structure level 1 dcl 1-620 in procedure "fort_optimizing_cg" set ref 9469 9469 9477* 9498* 9503* 10104 10104 10109* 10429* 13108* machine_state 5(18) based fixed bin(18,0) level 2 in structure "opt_statement" packed packed unsigned unaligned dcl 2-176 in procedure "fort_optimizing_cg" set ref 9461 9482* 10410 10427 10429 10431* 13078 13108 13109* machine_state_node 000730 constant fixed bin(4,0) initial dcl 4-87 set ref 9469* 9478 10112 macro_bits_inst based structure array level 1 dcl 2780 macro_cond_inst based structure array level 1 dcl 2800 macro_dt_inst based structure array level 1 dcl 2774 macro_if_inst based structure array level 1 dcl 2786 macro_instruction based structure array level 1 dcl 2758 set ref 3117 3495 3507 3513 3678 macro_proc parameter fixed bin(18,0) dcl 5321 in procedure "get_nextbase" ref 5316 5327 macro_proc parameter fixed bin(18,0) dcl 5249 in procedure "setup_call" ref 5244 5256 macro_proc 003654 automatic fixed bin(18,0) dcl 5230 in procedure "interpreter_proc" set ref 5232* 5234* 5239 macro_regs_inst based structure array level 1 dcl 2794 main_entry_point_name 56 based varying char(32) level 2 dcl 47 ref 1126 main_program constant fixed bin(9,0) initial dcl 4-68 ref 3581 7518 7560 13023 mantissa 0(08) 003542 automatic bit(64) level 2 packed packed unaligned dcl 2842 set ref 4581 4583* mantissa_of_power_of_fpbase 003544 automatic bit(64) packed unaligned dcl 2846 set ref 2966* 2968* 4581 map_ptr based bit(18) dcl 16-38 set ref 829* mask 006614 automatic fixed bin(35,0) dcl 12718 in procedure "generate_mask" set ref 12720* 12721 12723* mask 005631 automatic fixed bin(18,0) dcl 11461 in procedure "get_param_char_size" set ref 11490* 11493* 11501* mask_left constant bit(36) initial dcl 2597 ref 5932 5965 6017 6101 6150 max builtin function dcl 645 ref 7087 7305 7703 7788 8224 8309 8371 12018 12020 12780 12781 12893 12894 max_address_offset constant fixed bin(14,0) initial dcl 641 ref 1453 1453 max_fixed_bin_18 constant fixed bin(18,0) initial dcl 4-58 ref 7897 max_linkage_size 000610 constant fixed bin(18,0) initial dcl 642 set ref 1703* 1718 1718 1718 1772 1772 1772 1876 1876 1876 14132 14135 max_local 2 002047 automatic fixed bin(17,0) level 2 in structure "index_data" dcl 2748 in procedure "interpreter" set ref 8224* 8224 8371* 8371 11993* 12018 max_local 2 001675 automatic fixed bin(17,0) level 2 in structure "ptr_data" dcl 2737 in procedure "interpreter" set ref 7305* 7305 7788* 7788 11985* 12020 max_locked 3 001675 automatic fixed bin(17,0) level 2 in structure "ptr_data" dcl 2737 in procedure "interpreter" set ref 7703* 7703 11985* 12020 max_locked 3 002047 automatic fixed bin(17,0) level 2 in structure "index_data" dcl 2748 in procedure "interpreter" set ref 8309* 8309 11993* 12018 max_operators 001453 automatic fixed bin(18,0) dcl 2561 in procedure "interpreter" set ref 8334 12632 12999* max_operators 56(18) based fixed bin(18,0) level 2 in structure "subprogram" packed packed