|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
00001 /* 00002 00003 Copyright (C) 2000, 2001 Silicon Graphics, Inc. All Rights Reserved. 00004 00005 This program is free software; you can redistribute it and/or modify it 00006 under the terms of version 2 of the GNU General Public License as 00007 published by the Free Software Foundation. 00008 00009 This program is distributed in the hope that it would be useful, but 00010 WITHOUT ANY WARRANTY; without even the implied warranty of 00011 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00012 00013 Further, this software is distributed without any warranty that it is 00014 free of the rightful claim of any third person regarding infringement 00015 or the like. Any license provided herein, whether implied or 00016 otherwise, applies only to this software file. Patent licenses, if 00017 any, provided herein do not apply to combinations of this program with 00018 other software, or any other product whatsoever. 00019 00020 You should have received a copy of the GNU General Public License along 00021 with this program; if not, write the Free Software Foundation, Inc., 59 00022 Temple Place - Suite 330, Boston MA 02111-1307, USA. 00023 00024 Contact information: Silicon Graphics, Inc., 1600 Amphitheatre Pky, 00025 Mountain View, CA 94043, or: 00026 00027 http://www.sgi.com 00028 00029 For further information regarding this notice, see: 00030 00031 http://oss.sgi.com/projects/GenInfo/NoticeExplan 00032 00033 */ 00034 00035 00036 00037 static char USMID[] = "\n@(#)5.0_pl/sources/inline.c 5.8 08/09/99 17:48:48\n"; 00038 00039 # include "defines.h" /* Machine dependent ifdefs */ 00040 00041 # include "host.m" /* Host machine dependent macros.*/ 00042 # include "host.h" /* Host machine dependent header.*/ 00043 # include "target.m" /* Target machine dependent macros.*/ 00044 # include "target.h" /* Target machine dependent header.*/ 00045 # include "globals.m" 00046 # include "tokens.m" 00047 # include "sytb.m" 00048 # include "debug.m" 00049 # include "s_globals.m" 00050 00051 # include "globals.h" 00052 # include "tokens.h" 00053 # include "sytb.h" 00054 # include "p_globals.h" 00055 # include "s_globals.h" 00056 00057 00058 static int parallel_region; 00059 static int call_sh; 00060 static int sh_count; 00061 static int npi; 00062 static int loop_nest; 00063 static int pgm_attr_idx; 00064 static int entry_label_attr_idx; 00065 static int exit_label_attr_idx; 00066 static int call_line_number; 00067 static int call_col_number; 00068 static int number_of_actual_args; 00069 static int number_of_dummy_args; 00070 static boolean table_overflow; 00071 static boolean function_call; 00072 static boolean something_was_inlined; 00073 static boolean processing_ENTRY_called; 00074 static boolean inlinable = TRUE; 00075 static boolean noinline_in_effect; 00076 static boolean inline_in_effect; 00077 static int copy_head; 00078 static int next_label_slot; 00079 static int next_copy_out_sh_idx; 00080 static int old_label[MAX_INLINE_LABELS]; 00081 static int new_label[MAX_INLINE_LABELS]; 00082 static int actual_arg_attrs[MAX_INLINE_ARGS]; 00083 static opnd_type flipped_opnd[MAX_INLINE_ARGS]; 00084 static opnd_type actual_opnd[MAX_INLINE_ARGS]; 00085 static opnd_type dummy_opnd[MAX_INLINE_ARGS]; 00086 static opnd_type subscripting_tree[MAX_INLINE_ARGS]; 00087 static opnd_type substringing_tree[MAX_INLINE_ARGS]; 00088 static opnd_type struct_tree[MAX_INLINE_ARGS]; 00089 static opnd_type substring_offset[MAX_INLINE_ARGS]; 00090 static opnd_type linearized_offset[MAX_INLINE_ARGS][9]; 00091 static opnd_type substring_len[MAX_INLINE_ARGS]; 00092 static int copy_out_sh[MAX_INLINE_ARGS]; 00093 static int next_pgm_idx[MAX_INLINED_ROUTINES]; 00094 static opnd_type subscript[9]; 00095 static opnd_type subscript_attr[9]; 00096 00097 00098 00099 /******************************************************************************\ 00100 |* *| 00101 |* Description: *| 00102 |* This routine validates the mapping between an actual and dummy *| 00103 |* argument. *| 00104 |* *| 00105 |* Input parameters: *| 00106 |* NONE *| 00107 |* *| 00108 |* Output parameters: *| 00109 |* NONE *| 00110 |* *| 00111 |* Returns: *| 00112 |* TRUE if name substitution is possible *| 00113 |* *| 00114 \******************************************************************************/ 00115 boolean check_actual_and_dummy(opnd_type actual, 00116 opnd_type dummy, 00117 int arg) /* JEFFL - not used */ 00118 00119 { 00120 00121 int actual_bd_idx; 00122 int dummy_bd_idx; 00123 int i; 00124 boolean result = FALSE; 00125 00126 TRACE (Func_Entry, "check_actual_and_dummy", NULL); 00127 00128 if (inlinable) { 00129 switch(OPND_FLD(actual)) { 00130 case CN_Tbl_Idx : 00131 if (TYP_TYPE(CN_TYPE_IDX(OPND_IDX(actual))) != 00132 TYP_TYPE(ATD_TYPE_IDX(OPND_IDX(dummy)))) { 00133 inlinable = FALSE; 00134 PRINTMSG(call_line_number, 00135 1328, 00136 Inline, 00137 call_col_number, 00138 AT_OBJ_NAME_PTR(pgm_attr_idx)); 00139 } 00140 else { 00141 if ((TYP_TYPE(ATD_TYPE_IDX(OPND_IDX(dummy))) == Real || 00142 TYP_TYPE(ATD_TYPE_IDX(OPND_IDX(dummy))) == Complex || 00143 TYP_TYPE(ATD_TYPE_IDX(OPND_IDX(dummy))) == Integer) && 00144 TYP_LINEAR(CN_TYPE_IDX(OPND_IDX(actual))) != 00145 TYP_LINEAR(ATD_TYPE_IDX(OPND_IDX(dummy)))) { 00146 inlinable = FALSE; 00147 PRINTMSG(call_line_number, 00148 1328, 00149 Inline, 00150 call_col_number, 00151 AT_OBJ_NAME_PTR(pgm_attr_idx)); 00152 } 00153 } 00154 00155 if (ATD_ARRAY_IDX(OPND_IDX(dummy)) != NULL_IDX) { 00156 inlinable = FALSE; 00157 PRINTMSG(call_line_number, 00158 1330, 00159 Inline, 00160 call_col_number, 00161 AT_OBJ_NAME_PTR(pgm_attr_idx)); 00162 } 00163 00164 break; 00165 00166 case AT_Tbl_Idx : 00167 if (AT_OBJ_CLASS(OPND_IDX(dummy)) == Data_Obj && 00168 AT_OBJ_CLASS(OPND_IDX(actual)) == Data_Obj) { 00169 00170 if (TYP_TYPE(ATD_TYPE_IDX(OPND_IDX(actual))) != 00171 TYP_TYPE(ATD_TYPE_IDX(OPND_IDX(dummy)))) { 00172 inlinable = FALSE; 00173 PRINTMSG(call_line_number, 00174 1328, 00175 Inline, 00176 call_col_number, 00177 AT_OBJ_NAME_PTR(pgm_attr_idx)); 00178 } 00179 else { 00180 if ((TYP_TYPE(ATD_TYPE_IDX(OPND_IDX(dummy))) == Real || 00181 TYP_TYPE(ATD_TYPE_IDX(OPND_IDX(dummy))) == Complex || 00182 TYP_TYPE(ATD_TYPE_IDX(OPND_IDX(dummy))) == Integer) && 00183 TYP_LINEAR(ATD_TYPE_IDX(OPND_IDX(actual))) != 00184 TYP_LINEAR(ATD_TYPE_IDX(OPND_IDX(dummy)))) { 00185 inlinable = FALSE; 00186 PRINTMSG(call_line_number, 00187 1328, 00188 Inline, 00189 call_col_number, 00190 AT_OBJ_NAME_PTR(pgm_attr_idx)); 00191 } 00192 } 00193 00194 if ((ATD_RESHAPE_ARRAY_OPT(OPND_IDX(actual)) || 00195 ATD_RESHAPE_ARRAY_OPT(OPND_IDX(dummy))) && 00196 ATD_ARRAY_IDX(OPND_IDX(actual)) != NULL_IDX && 00197 ATD_ARRAY_IDX(OPND_IDX(dummy)) != NULL_IDX && 00198 BD_RANK(ATD_ARRAY_IDX(OPND_IDX(actual))) < 00199 BD_RANK(ATD_ARRAY_IDX(OPND_IDX(dummy)))) { 00200 inlinable = FALSE; 00201 PRINTMSG(call_line_number, 00202 1646, 00203 Error, 00204 call_col_number, 00205 AT_OBJ_NAME_PTR(OPND_IDX(actual)), 00206 AT_OBJ_NAME_PTR(OPND_IDX(dummy))); 00207 } 00208 00209 if (inlinable && 00210 ATD_ARRAY_IDX(OPND_IDX(actual)) != NULL_IDX && 00211 ATD_ARRAY_IDX(OPND_IDX(dummy)) != NULL_IDX && 00212 BD_RANK(ATD_ARRAY_IDX(OPND_IDX(actual))) == 00213 BD_RANK(ATD_ARRAY_IDX(OPND_IDX(dummy)))) { 00214 00215 actual_bd_idx = ATD_ARRAY_IDX(OPND_IDX(actual)); 00216 dummy_bd_idx = ATD_ARRAY_IDX(OPND_IDX(dummy)); 00217 00218 result = TRUE; 00219 for (i = 1; i < BD_RANK(dummy_bd_idx); i++) { 00220 if (!(BD_LB_FLD(actual_bd_idx, i) == CN_Tbl_Idx && 00221 BD_LB_FLD(dummy_bd_idx, i) == CN_Tbl_Idx && 00222 fold_relationals(BD_LB_IDX(actual_bd_idx,i), 00223 BD_LB_IDX(dummy_bd_idx,i), 00224 Eq_Opr) && 00225 BD_UB_FLD(actual_bd_idx, i) == CN_Tbl_Idx && 00226 BD_UB_FLD(dummy_bd_idx, i) == CN_Tbl_Idx && 00227 fold_relationals(BD_UB_IDX(actual_bd_idx,i), 00228 BD_UB_IDX(dummy_bd_idx,i), 00229 Eq_Opr))) { 00230 result = FALSE; 00231 } 00232 } 00233 00234 if (!(BD_LB_FLD(actual_bd_idx, i) == CN_Tbl_Idx && 00235 BD_LB_FLD(dummy_bd_idx, i) == CN_Tbl_Idx && 00236 fold_relationals(BD_LB_IDX(actual_bd_idx,i), 00237 BD_LB_IDX(dummy_bd_idx,i), 00238 Eq_Opr))) { 00239 result = FALSE; 00240 } 00241 00242 /* 00243 We will not do name substitution with structure components. 00244 We will not do name substitution if dummy argument was scoped. 00245 We will not do name substitution with character. 00246 */ 00247 if (ATD_CLASS(OPND_IDX(actual)) == Struct_Component || 00248 ATD_WAS_SCOPED(OPND_IDX(dummy)) || 00249 TYP_TYPE(ATD_TYPE_IDX(OPND_IDX(actual))) == Character) { 00250 result = FALSE; 00251 } 00252 } 00253 00254 if (ATD_ARRAY_IDX(OPND_IDX(actual)) == NULL_IDX && 00255 ATD_ARRAY_IDX(OPND_IDX(dummy)) != NULL_IDX) { 00256 inlinable = FALSE; 00257 PRINTMSG(call_line_number, 00258 1330, 00259 Inline, 00260 call_col_number, 00261 AT_OBJ_NAME_PTR(pgm_attr_idx)); 00262 } 00263 00264 if (ATD_PE_ARRAY_IDX(OPND_IDX(actual)) != NULL_IDX) { 00265 inlinable = FALSE; 00266 PRINTMSG(call_line_number, 00267 1612, 00268 Inline, 00269 call_col_number, 00270 AT_OBJ_NAME_PTR(pgm_attr_idx)); 00271 } 00272 00273 } 00274 break; 00275 } 00276 } 00277 00278 TRACE (Func_Exit, "check_actual_and_dummy", NULL); 00279 00280 return(result); 00281 00282 } /* check_actual_and_dummy */ 00283 00284 00285 00286 00287 /******************************************************************************\ 00288 |* *| 00289 |* Description: *| 00290 |* Map a scalar dope-vector actual argument *| 00291 |* onto a scalar non dope-vector dummy argument. *| 00292 |* argument. *| 00293 |* *| 00294 |* Input parameters: *| 00295 |* i *| 00296 |* dummy_referenced *| 00297 |* *| 00298 |* Output parameters: *| 00299 |* copy_out_DV_scalar *| 00300 |* *| 00301 |* Returns: *| 00302 |* NOTHING *| 00303 |* *| 00304 \******************************************************************************/ 00305 void scalar_dope_to_scalar(int i, 00306 int *copy_out_DV_scalar, 00307 boolean dummy_referenced) 00308 00309 { 00310 00311 int asg_idx; 00312 int div_idx; 00313 int dv_deref_idx; 00314 int tmp_attr; 00315 00316 00317 TRACE (Func_Entry, "scalar_dope_to_scalar", NULL); 00318 00319 if (TYP_TYPE(ATD_TYPE_IDX(OPND_IDX(dummy_opnd[i]))) == Character && 00320 TYP_CHAR_CLASS(ATD_TYPE_IDX(OPND_IDX(dummy_opnd[i]))) == 00321 Assumed_Size_Char) { 00322 NTR_IR_TBL(asg_idx); 00323 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 00324 IR_OPR(asg_idx) = Dv_Access_El_Len; 00325 IR_LINE_NUM(asg_idx) = call_line_number; 00326 IR_COL_NUM(asg_idx) = call_col_number; 00327 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 00328 IR_IDX_L(asg_idx) = IR_IDX_L(OPND_IDX(actual_opnd[i])); 00329 IR_LINE_NUM_L(asg_idx) = call_line_number; 00330 IR_COL_NUM_L(asg_idx) = call_col_number; 00331 00332 NTR_IR_TBL(div_idx); 00333 IR_TYPE_IDX(div_idx) = CG_INTEGER_DEFAULT_TYPE; 00334 IR_OPR(div_idx) = Shiftr_Opr; 00335 IR_LINE_NUM(div_idx) = call_line_number; 00336 IR_COL_NUM(div_idx) = call_col_number; 00337 IR_FLD_L(div_idx) = IR_Tbl_Idx; 00338 IR_IDX_L(div_idx) = asg_idx; 00339 IR_LINE_NUM_L(div_idx) = call_line_number; 00340 IR_COL_NUM_L(div_idx) = call_col_number; 00341 IR_FLD_R(div_idx) = CN_Tbl_Idx; 00342 IR_IDX_R(div_idx) = CN_INTEGER_THREE_IDX; 00343 IR_LINE_NUM_R(div_idx) = call_line_number; 00344 IR_COL_NUM_R(div_idx) = call_col_number; 00345 OPND_IDX(substring_len[i]) = div_idx; 00346 OPND_FLD(substring_len[i]) = IR_Tbl_Idx; 00347 } 00348 00349 COPY_OPND(actual_opnd[i], IR_OPND_L(OPND_IDX(actual_opnd[i]))); 00350 00351 NTR_IR_TBL(dv_deref_idx); 00352 IR_TYPE_IDX(dv_deref_idx) = ATD_TYPE_IDX(OPND_IDX(dummy_opnd[i])); 00353 IR_OPR(dv_deref_idx) = Dv_Deref_Opr; 00354 IR_LINE_NUM(dv_deref_idx) = call_line_number; 00355 IR_COL_NUM(dv_deref_idx) = call_col_number; 00356 IR_FLD_L(dv_deref_idx) = OPND_FLD(actual_opnd[i]); 00357 IR_IDX_L(dv_deref_idx) = OPND_IDX(actual_opnd[i]); 00358 IR_LINE_NUM_L(dv_deref_idx) = call_line_number; 00359 IR_COL_NUM_L(dv_deref_idx) = call_col_number; 00360 00361 OPND_IDX(subscripting_tree[i]) = dv_deref_idx; 00362 OPND_FLD(subscripting_tree[i]) = IR_Tbl_Idx; 00363 00364 tmp_attr = gen_compiler_tmp(call_line_number, 00365 call_col_number, 00366 Priv, 00367 TRUE); 00368 ATD_STOR_BLK_IDX(tmp_attr) = SCP_SB_STACK_IDX(curr_scp_idx); 00369 ATD_TYPE_IDX(tmp_attr) = ATD_TYPE_IDX(OPND_IDX(dummy_opnd[i])); 00370 AT_SEMANTICS_DONE(tmp_attr) = TRUE; 00371 00372 if (inlinable && dummy_referenced) { 00373 NTR_IR_TBL(asg_idx); 00374 IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(OPND_IDX(dummy_opnd[i])); 00375 IR_OPR(asg_idx) = Asg_Opr; 00376 IR_LINE_NUM(asg_idx) = call_line_number; 00377 IR_COL_NUM(asg_idx) = call_col_number; 00378 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 00379 IR_IDX_L(asg_idx) = tmp_attr; 00380 IR_LINE_NUM_L(asg_idx) = call_line_number; 00381 IR_COL_NUM_L(asg_idx) = call_col_number; 00382 IR_FLD_R(asg_idx) = OPND_FLD(subscripting_tree[i]); 00383 IR_IDX_R(asg_idx) = OPND_IDX(subscripting_tree[i]); 00384 IR_LINE_NUM_R(asg_idx) = call_line_number; 00385 IR_COL_NUM_R(asg_idx) = call_col_number; 00386 00387 curr_stmt_sh_idx = call_sh; 00388 gen_sh(Before, 00389 Assignment_Stmt, 00390 call_line_number, 00391 call_col_number, 00392 FALSE, 00393 FALSE, 00394 TRUE); 00395 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 00396 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 00397 } 00398 00399 OPND_IDX(actual_opnd[i]) = tmp_attr; 00400 OPND_FLD(actual_opnd[i]) = AT_Tbl_Idx; 00401 *copy_out_DV_scalar = tmp_attr; 00402 00403 TRACE (Func_Exit, "scalar_dope_to_scalar", NULL); 00404 00405 return; 00406 00407 } /* scalar_dope_to_scalar */ 00408 00409 00410 00411 00412 00413 /******************************************************************************\ 00414 |* *| 00415 |* Description: *| 00416 |* Map an array element actual argument *| 00417 |* onto a scalar dummy argument. *| 00418 |* argument. *| 00419 |* *| 00420 |* Input parameters: *| 00421 |* i *| 00422 |* dummy_referenced *| 00423 |* dummy_modified *| 00424 |* *| 00425 |* Output parameters: *| 00426 |* copy_out_array_element *| 00427 |* *| 00428 |* Returns: *| 00429 |* NOTHING *| 00430 |* *| 00431 \******************************************************************************/ 00432 void array_element_to_scalar(int i, 00433 int *copy_out_array_element, 00434 boolean dummy_referenced, 00435 boolean dummy_modified) 00436 00437 { 00438 00439 int l; 00440 int line; 00441 int col; 00442 int asg_idx; 00443 int attr_idx; 00444 int list_idx; 00445 int tmp_attr; 00446 00447 00448 TRACE (Func_Entry, "array_element_to_scalar", NULL); 00449 COPY_OPND(subscripting_tree[i], actual_opnd[i]); 00450 00451 /* 00452 If we are going to have to do a copy out, then you 00453 need to save the index expressions of the array 00454 reference on entry to the inlined code. 00455 */ 00456 if (dummy_modified) { 00457 list_idx = IR_IDX_R(OPND_IDX(actual_opnd[i])); 00458 for (l = 1; 00459 l <= IR_LIST_CNT_R(OPND_IDX(actual_opnd[i])); 00460 l++) { 00461 COPY_OPND(subscript[l], IL_OPND(list_idx)); 00462 list_idx = IL_NEXT_LIST_IDX(list_idx); 00463 00464 tmp_attr = gen_compiler_tmp(call_line_number, 00465 call_col_number, 00466 Priv, 00467 TRUE); 00468 ATD_STOR_BLK_IDX(tmp_attr) = SCP_SB_STACK_IDX(curr_scp_idx); 00469 ATD_TYPE_IDX(tmp_attr) = INTEGER_DEFAULT_TYPE; 00470 AT_SEMANTICS_DONE(tmp_attr) = TRUE; 00471 00472 NTR_IR_TBL(asg_idx); 00473 IR_TYPE_IDX(asg_idx) = INTEGER_DEFAULT_TYPE; 00474 IR_OPR(asg_idx) = Asg_Opr; 00475 IR_LINE_NUM(asg_idx) = call_line_number; 00476 IR_COL_NUM(asg_idx) = call_col_number; 00477 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 00478 IR_IDX_L(asg_idx) = tmp_attr; 00479 IR_LINE_NUM_L(asg_idx) = call_line_number; 00480 IR_COL_NUM_L(asg_idx) = call_col_number; 00481 IR_FLD_R(asg_idx) = OPND_FLD(subscript[l]); 00482 IR_IDX_R(asg_idx) = OPND_IDX(subscript[l]); 00483 IR_LINE_NUM_R(asg_idx) = call_line_number; 00484 IR_COL_NUM_R(asg_idx) = call_col_number; 00485 00486 curr_stmt_sh_idx = call_sh; 00487 gen_sh(Before, 00488 Assignment_Stmt, 00489 call_line_number, 00490 call_col_number, 00491 FALSE, 00492 FALSE, 00493 TRUE); 00494 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 00495 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 00496 00497 OPND_IDX(subscript_attr[l]) = tmp_attr; 00498 OPND_FLD(subscript_attr[l]) = AT_Tbl_Idx; 00499 OPND_LINE_NUM(subscript_attr[l]) = call_line_number; 00500 OPND_COL_NUM(subscript_attr[l]) = call_col_number; 00501 } 00502 } 00503 00504 tmp_attr = gen_compiler_tmp(call_line_number, 00505 call_col_number, 00506 Priv, 00507 TRUE); 00508 ATD_STOR_BLK_IDX(tmp_attr) = SCP_SB_STACK_IDX(curr_scp_idx); 00509 00510 attr_idx = find_base_attr(&actual_opnd[i], 00511 &line, 00512 &col); 00513 00514 ATD_TYPE_IDX(tmp_attr) = ATD_TYPE_IDX(attr_idx); 00515 AT_SEMANTICS_DONE(tmp_attr) = TRUE; 00516 00517 if (dummy_referenced) { 00518 NTR_IR_TBL(asg_idx); 00519 IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(attr_idx); 00520 IR_OPR(asg_idx) = Asg_Opr; 00521 IR_LINE_NUM(asg_idx) = call_line_number; 00522 IR_COL_NUM(asg_idx) = call_col_number; 00523 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 00524 IR_IDX_L(asg_idx) = tmp_attr; 00525 IR_LINE_NUM_L(asg_idx) = call_line_number; 00526 IR_COL_NUM_L(asg_idx) = call_col_number; 00527 IR_FLD_R(asg_idx) = OPND_FLD(actual_opnd[i]); 00528 IR_IDX_R(asg_idx) = OPND_IDX(actual_opnd[i]); 00529 IR_LINE_NUM_R(asg_idx) = call_line_number; 00530 IR_COL_NUM_R(asg_idx) = call_col_number; 00531 00532 curr_stmt_sh_idx = call_sh; 00533 gen_sh(Before, 00534 Assignment_Stmt, 00535 call_line_number, 00536 call_col_number, 00537 FALSE, 00538 FALSE, 00539 TRUE); 00540 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 00541 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 00542 } 00543 00544 OPND_IDX(actual_opnd[i]) = tmp_attr; 00545 OPND_FLD(actual_opnd[i]) = AT_Tbl_Idx; 00546 *copy_out_array_element = tmp_attr; 00547 00548 TRACE (Func_Exit, "array_element_to_scalar", NULL); 00549 00550 return; 00551 00552 } /* array_element_to_scalar */ 00553 00554 00555 00556 00557 /******************************************************************************\ 00558 |* *| 00559 |* Description: *| 00560 |* Map a scalar character actual argument *| 00561 |* onto a scalar character dummy argument. *| 00562 |* Map an character array actual argument *| 00563 |* onto a character array dummy argument. *| 00564 |* *| 00565 |* Input parameters: *| 00566 |* i *| 00567 |* *| 00568 |* Output parameters: *| 00569 |* NONE *| 00570 |* *| 00571 |* Returns: *| 00572 |* NOTHING *| 00573 |* *| 00574 \******************************************************************************/ 00575 void character_to_character(int i) 00576 00577 { 00578 00579 int asg_idx; 00580 int minus_idx; 00581 int substring_list_idx; 00582 int tmp_attr; 00583 00584 00585 TRACE (Func_Entry, "character_to_character", NULL); 00586 00587 COPY_OPND(substringing_tree[i], actual_opnd[i]); 00588 00589 substring_list_idx = IR_IDX_R(OPND_IDX(actual_opnd[i])); 00590 NTR_IR_TBL(minus_idx); 00591 IR_OPR(minus_idx) = Minus_Opr; 00592 IR_TYPE_IDX(minus_idx) = CG_INTEGER_DEFAULT_TYPE; 00593 IR_LINE_NUM(minus_idx) = call_line_number; 00594 IR_COL_NUM(minus_idx) = call_col_number; 00595 COPY_OPND(IR_OPND_L(minus_idx), IL_OPND(substring_list_idx)); 00596 IR_LINE_NUM_L(minus_idx) = call_line_number; 00597 IR_COL_NUM_L(minus_idx) = call_col_number; 00598 IR_IDX_R(minus_idx) = CN_INTEGER_ONE_IDX; 00599 IR_FLD_R(minus_idx) = CN_Tbl_Idx; 00600 IR_LINE_NUM_R(minus_idx) = call_line_number; 00601 IR_COL_NUM_R(minus_idx) = call_col_number; 00602 OPND_IDX(substring_offset[i]) = minus_idx; 00603 OPND_FLD(substring_offset[i]) = IR_Tbl_Idx; 00604 00605 if (TYP_CHAR_CLASS(ATD_TYPE_IDX(OPND_IDX(dummy_opnd[i]))) == 00606 Assumed_Size_Char) { 00607 substring_list_idx = IL_NEXT_LIST_IDX(substring_list_idx); 00608 substring_list_idx = IL_NEXT_LIST_IDX(substring_list_idx); 00609 COPY_OPND(substring_len[i], IL_OPND(substring_list_idx)); 00610 } 00611 00612 COPY_OPND(actual_opnd[i], IR_OPND_L(OPND_IDX(actual_opnd[i]))); 00613 00614 if (OPND_FLD(actual_opnd[i]) == IR_Tbl_Idx && 00615 IR_OPR(OPND_IDX(actual_opnd[i])) == Dv_Deref_Opr) { 00616 inlinable = FALSE; 00617 PRINTMSG(call_line_number, 00618 1202, 00619 Inline, 00620 call_col_number, 00621 AT_OBJ_NAME_PTR(pgm_attr_idx), 00622 "the compiler cannot support this mapping"); 00623 } 00624 00625 if (OPND_FLD(actual_opnd[i]) == IR_Tbl_Idx && 00626 IR_OPR(OPND_IDX(actual_opnd[i])) == Subscript_Opr && 00627 ATD_ARRAY_IDX(OPND_IDX(dummy_opnd[i])) == NULL_IDX) { 00628 inlinable = FALSE; 00629 PRINTMSG(call_line_number, 00630 1202, 00631 Inline, 00632 call_col_number, 00633 AT_OBJ_NAME_PTR(pgm_attr_idx), 00634 "the compiler cannot support this mapping"); 00635 } 00636 00637 tmp_attr = gen_compiler_tmp(call_line_number, 00638 call_col_number, 00639 Priv, 00640 TRUE); 00641 ATD_STOR_BLK_IDX(tmp_attr) = SCP_SB_STACK_IDX(curr_scp_idx); 00642 ATD_TYPE_IDX(tmp_attr) = CG_INTEGER_DEFAULT_TYPE; 00643 AT_SEMANTICS_DONE(tmp_attr) = TRUE; 00644 00645 NTR_IR_TBL(asg_idx); 00646 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 00647 IR_OPR(asg_idx) = Asg_Opr; 00648 IR_LINE_NUM(asg_idx) = call_line_number; 00649 IR_COL_NUM(asg_idx) = call_col_number; 00650 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 00651 IR_IDX_L(asg_idx) = tmp_attr; 00652 IR_LINE_NUM_L(asg_idx) = call_line_number; 00653 IR_COL_NUM_L(asg_idx) = call_col_number; 00654 IR_FLD_R(asg_idx) = OPND_FLD(substring_offset[i]); 00655 IR_IDX_R(asg_idx) = OPND_IDX(substring_offset[i]); 00656 IR_LINE_NUM_R(asg_idx) = call_line_number; 00657 IR_COL_NUM_R(asg_idx) = call_col_number; 00658 00659 curr_stmt_sh_idx = call_sh; 00660 gen_sh(Before, 00661 Assignment_Stmt, 00662 call_line_number, 00663 call_col_number, 00664 FALSE, 00665 FALSE, 00666 TRUE); 00667 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 00668 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 00669 00670 OPND_IDX(substring_offset[i]) = tmp_attr; 00671 OPND_FLD(substring_offset[i]) = AT_Tbl_Idx; 00672 00673 TRACE (Func_Exit, "character_to_character", NULL); 00674 00675 return; 00676 00677 } /* character_to_character */ 00678 00679 00680 00681 00682 00683 /******************************************************************************\ 00684 |* *| 00685 |* Description: *| 00686 |* Create new ir, sh or il entries that are a copy of the input entry. *| 00687 |* *| 00688 |* Input parameters: *| 00689 |* idx table idx of entry to be copied. *| 00690 |* fld fld type of idx. *| 00691 |* *| 00692 |* Output parameters: *| 00693 |* NONE *| 00694 |* *| 00695 |* Returns: *| 00696 |* idx of new entry, same fld type as the input idx. *| 00697 |* *| 00698 \******************************************************************************/ 00699 00700 int copy_sbtree(int idx, 00701 fld_type fld) 00702 00703 { 00704 id_str_type name; 00705 int i; 00706 int j; 00707 int k; 00708 int sub; 00709 int trp; 00710 int list_idx; 00711 int attr_idx; 00712 int original_idx; 00713 int cn_idx; 00714 int plus_idx; 00715 int sb_idx; 00716 int il_idx; 00717 int tmp_idx1; 00718 int tmp_idx2; 00719 int outer_sb_idx; 00720 int new_label_attr; 00721 int module_attr_idx; 00722 int name_idx; 00723 int new_root = NULL_IDX; 00724 int new_idx; 00725 int function_attr; 00726 int flipped_bd_idx; 00727 int dummy_bd_idx; 00728 int new_blk; 00729 int flipped_array = 0; 00730 int type_idx2; 00731 int trail; 00732 int match = 0; 00733 boolean found; 00734 long_type cnst[MAX_WORDS_FOR_INTEGER]; 00735 long_type folded_const[MAX_WORDS_FOR_NUMERIC]; 00736 00737 00738 TRACE (Func_Entry, "copy_sbtree", NULL); 00739 00740 if (idx != NULL_IDX) { 00741 00742 switch(fld) { 00743 00744 case NO_Tbl_Idx : 00745 break; 00746 00747 case IR_Tbl_Idx : 00748 NTR_IR_TBL(new_root); 00749 00750 /* 00751 This check here is a saftey value. Table size 00752 is checked here. If we are approaching dangerous limits, 00753 we just stop inlining. The value is arbitrary. 00754 */ 00755 if (new_root > MAX_INLINE_IR) { 00756 table_overflow = TRUE; 00757 inlinable = FALSE; 00758 } 00759 00760 COPY_TBL_NTRY(ir_tbl, new_root, idx); 00761 IR_LINE_NUM(new_root) = call_line_number; 00762 IR_COL_NUM(new_root) = call_col_number; 00763 00764 new_idx = copy_sbtree(IR_IDX_L(idx), IR_FLD_L(idx)); 00765 IR_IDX_L(new_root) = new_idx; 00766 if (IR_FLD_L(idx) == AT_Tbl_Idx) { 00767 for (i = 0; i <= number_of_dummy_args; i++) { 00768 if (IR_IDX_L(idx) == OPND_IDX(dummy_opnd[i])) { 00769 match = i; 00770 00771 if ((IR_OPR(idx) == Subscript_Opr || 00772 IR_OPR(idx) == Section_Subscript_Opr || 00773 IR_OPR(idx) == Whole_Subscript_Opr) && 00774 ATD_RESHAPE_ARRAY_OPT(OPND_IDX(flipped_opnd[i]))) { 00775 flipped_bd_idx = 00776 ATD_ARRAY_IDX(OPND_IDX(flipped_opnd[i])); 00777 dummy_bd_idx = 00778 ATD_ARRAY_IDX(OPND_IDX(dummy_opnd[i])); 00779 00780 if (dummy_bd_idx != NULL_IDX && 00781 flipped_bd_idx != NULL_IDX && 00782 BD_RANK(dummy_bd_idx) < BD_RANK(flipped_bd_idx)) { 00783 flipped_array = BD_RANK(flipped_bd_idx) - 00784 BD_RANK(dummy_bd_idx) ; 00785 } 00786 } 00787 00788 if (OPND_FLD(actual_opnd[i]) == AT_Tbl_Idx && 00789 ATD_AUTOMATIC(OPND_IDX(actual_opnd[i]))) { 00790 COPY_OPND(IR_OPND_L(new_root), actual_opnd[i]); 00791 } 00792 else if (OPND_IDX(struct_tree[i]) != NULL_IDX) { 00793 COPY_OPND(IR_OPND_L(new_root), struct_tree[i]); 00794 } 00795 else { 00796 COPY_OPND(IR_OPND_L(new_root), actual_opnd[i]); 00797 } 00798 } 00799 } 00800 00801 if (AT_OBJ_CLASS(IR_IDX_L(idx)) == Label) { 00802 for (k = 0; k < next_label_slot; k++) { 00803 if (IR_IDX_L(idx) == old_label[k]) { 00804 break; 00805 } 00806 } 00807 00808 if (k < next_label_slot) { 00809 IR_IDX_L(new_root) = new_label[k]; 00810 IR_FLD_L(new_root) = AT_Tbl_Idx; 00811 } 00812 else { 00813 old_label[next_label_slot] = IR_IDX_L(idx); 00814 new_label_attr = gen_internal_lbl(call_line_number); 00815 COPY_COMMON_ATTR_INFO(IR_IDX_L(idx), 00816 new_label_attr, 00817 Label); 00818 COPY_VARIANT_ATTR_INFO(IR_IDX_L(idx), 00819 new_label_attr, 00820 Label); 00821 AT_ATTR_LINK(new_label_attr) = NULL_IDX; 00822 new_label[next_label_slot] = new_label_attr; 00823 00824 IR_IDX_L(new_root) = new_label_attr; 00825 IR_FLD_L(new_root) = AT_Tbl_Idx; 00826 00827 if (ATL_DIRECTIVE_LIST(new_label_attr) != NULL_IDX) { 00828 il_idx = IL_IDX(ATL_DIRECTIVE_LIST(new_label_attr)) + 00829 Cache_Bypass_Dir_Idx; 00830 00831 if (IL_FLD(il_idx) == IL_Tbl_Idx) { 00832 il_idx = IL_IDX(il_idx); 00833 00834 while (il_idx != NULL_IDX) { 00835 for (i = 1; i <= number_of_dummy_args; i++) { 00836 if (OPND_IDX(dummy_opnd[i]) == IL_IDX(il_idx)){ 00837 IL_IDX(il_idx) = OPND_IDX(actual_opnd[i]); 00838 break; 00839 } 00840 } 00841 il_idx = IL_NEXT_LIST_IDX(il_idx); 00842 } 00843 } 00844 } 00845 00846 next_label_slot = next_label_slot + 1; 00847 if (next_label_slot == MAX_INLINE_LABELS) { 00848 next_label_slot = next_label_slot - 1; 00849 inlinable = FALSE; 00850 table_overflow = TRUE; 00851 } 00852 } 00853 } 00854 } 00855 00856 00857 if (IR_FLD_L(idx) != IL_Tbl_Idx) { 00858 IR_LINE_NUM_L(new_root) = call_line_number; 00859 IR_COL_NUM_L(new_root) = call_col_number; 00860 } 00861 00862 if (IR_FLD_R(idx) == IL_Tbl_Idx && IR_LIST_CNT_R(idx) == 0) { 00863 new_idx = NULL_IDX; 00864 } 00865 else { 00866 new_idx = copy_sbtree(IR_IDX_R(idx), IR_FLD_R(idx)); 00867 } 00868 00869 IR_IDX_R(new_root) = new_idx; 00870 00871 if (flipped_array > 0) { 00872 tmp_idx1 = NULL_IDX; 00873 tmp_idx2 = NULL_IDX; 00874 00875 il_idx = new_idx; 00876 while (il_idx != NULL_IDX) { 00877 tmp_idx1 = il_idx; 00878 il_idx = IL_NEXT_LIST_IDX(il_idx); 00879 } 00880 00881 for (i = 1; i <= flipped_array; i++) { 00882 NTR_IR_LIST_TBL(tmp_idx2); 00883 IL_FLD(tmp_idx2) = CN_Tbl_Idx; 00884 IL_IDX(tmp_idx2) = CN_INTEGER_ONE_IDX; 00885 IL_LINE_NUM(tmp_idx2) = call_line_number; 00886 IL_COL_NUM(tmp_idx2) = call_col_number; 00887 IL_PREV_LIST_IDX(tmp_idx2) = tmp_idx1; 00888 IL_NEXT_LIST_IDX(tmp_idx1) = tmp_idx2; 00889 tmp_idx1 = tmp_idx2; 00890 } 00891 00892 IR_LIST_CNT_R(new_root) = BD_RANK(flipped_bd_idx); 00893 } 00894 00895 if (IR_FLD_R(idx) == AT_Tbl_Idx) { 00896 for (i = 0; i <= number_of_dummy_args; i++) { 00897 if (IR_IDX_R(idx) == OPND_IDX(dummy_opnd[i])) { 00898 if (OPND_FLD(actual_opnd[i]) == AT_Tbl_Idx && 00899 ATD_AUTOMATIC(OPND_IDX(actual_opnd[i]))) { 00900 COPY_OPND(IR_OPND_R(new_root), actual_opnd[i]); 00901 } 00902 else if (OPND_IDX(struct_tree[i]) != NULL_IDX) { 00903 COPY_OPND(IR_OPND_R(new_root), struct_tree[i]); 00904 } 00905 else { 00906 COPY_OPND(IR_OPND_R(new_root), actual_opnd[i]); 00907 } 00908 } 00909 } 00910 00911 if (AT_OBJ_CLASS(IR_IDX_R(idx)) == Label) { 00912 for (k = 0; k < next_label_slot; k++) { 00913 if (IR_IDX_R(idx) == old_label[k]) { 00914 break; 00915 } 00916 } 00917 00918 if (k < next_label_slot) { 00919 IR_IDX_R(new_root) = new_label[k]; 00920 IR_FLD_R(new_root) = AT_Tbl_Idx; 00921 } 00922 else { 00923 old_label[next_label_slot] = IR_IDX_R(idx); 00924 new_label_attr = gen_internal_lbl(call_line_number); 00925 COPY_COMMON_ATTR_INFO(IR_IDX_R(idx), 00926 new_label_attr, 00927 Label); 00928 00929 COPY_VARIANT_ATTR_INFO(IR_IDX_R(idx), 00930 new_label_attr, 00931 Label); 00932 00933 AT_ATTR_LINK(new_label_attr) = NULL_IDX; 00934 new_label[next_label_slot] = new_label_attr; 00935 00936 IR_IDX_R(new_root) = new_label_attr; 00937 IR_FLD_R(new_root) = AT_Tbl_Idx; 00938 00939 if (ATL_DIRECTIVE_LIST(new_label_attr) != NULL_IDX) { 00940 il_idx = IL_IDX(ATL_DIRECTIVE_LIST(new_label_attr)) + 00941 Cache_Bypass_Dir_Idx; 00942 00943 if (IL_FLD(il_idx) == IL_Tbl_Idx) { 00944 il_idx = IL_IDX(il_idx); 00945 00946 while (il_idx != NULL_IDX) { 00947 for (i = 1; i <= number_of_dummy_args; i++) { 00948 if (OPND_IDX(dummy_opnd[i]) == IL_IDX(il_idx)){ 00949 IL_IDX(il_idx) = OPND_IDX(actual_opnd[i]); 00950 break; 00951 } 00952 } 00953 00954 il_idx = IL_NEXT_LIST_IDX(il_idx); 00955 } 00956 } 00957 } 00958 00959 next_label_slot = next_label_slot + 1; 00960 if (next_label_slot == MAX_INLINE_LABELS) { 00961 next_label_slot = next_label_slot - 1; 00962 inlinable = FALSE; 00963 table_overflow = TRUE; 00964 } 00965 } 00966 } 00967 } 00968 00969 if (IR_FLD_R(idx) != IL_Tbl_Idx) { 00970 IR_LINE_NUM_R(new_root) = call_line_number; 00971 IR_COL_NUM_R(new_root) = call_col_number; 00972 } 00973 00974 switch (IR_OPR(idx)) { 00975 case Whole_Substring_Opr : 00976 case Substring_Opr : 00977 attr_idx = find_left_attr(&IR_OPND_L(idx)); 00978 if (IR_FLD_L(idx) == AT_Tbl_Idx && 00979 !ATD_IM_A_DOPE(attr_idx)) { 00980 00981 for (i = 0; i <= number_of_dummy_args; i++) { 00982 if (attr_idx == OPND_IDX(dummy_opnd[i])) { 00983 sub = IR_IDX_R(new_root); 00984 for (j = 1; j <= 2; j++) { 00985 NTR_IR_TBL(plus_idx); 00986 IR_OPR(plus_idx) = Plus_Opr; 00987 IR_TYPE_IDX(plus_idx) = CG_INTEGER_DEFAULT_TYPE; 00988 IR_LINE_NUM(plus_idx) = call_line_number; 00989 IR_COL_NUM(plus_idx) = call_col_number; 00990 COPY_OPND(IR_OPND_L(plus_idx), IL_OPND(sub)); 00991 IR_LINE_NUM_L(plus_idx) = call_line_number; 00992 IR_COL_NUM_L(plus_idx) = call_col_number; 00993 COPY_OPND(IR_OPND_R(plus_idx), 00994 substring_offset[i]); 00995 IR_LINE_NUM_R(plus_idx) = call_line_number; 00996 IR_COL_NUM_R(plus_idx) = call_col_number; 00997 00998 IL_FLD(sub) = IR_Tbl_Idx; 00999 IL_IDX(sub) = plus_idx; 01000 sub = IL_NEXT_LIST_IDX(sub); 01001 } 01002 } 01003 } 01004 } 01005 break; 01006 01007 01008 case Whole_Subscript_Opr : 01009 case Section_Subscript_Opr : 01010 case Subscript_Opr : 01011 attr_idx = find_left_attr(&IR_OPND_L(idx)); 01012 for (i = 0; i <= number_of_dummy_args; i++) { 01013 if (attr_idx == OPND_IDX(dummy_opnd[i])) { 01014 sub = IR_IDX_R(new_root); 01015 k = 1; 01016 while (sub != NULL_IDX) { 01017 if (IL_FLD(sub) == IR_Tbl_Idx && 01018 IR_OPR(IL_IDX(sub)) == Triplet_Opr) { 01019 trp = IR_IDX_L(IL_IDX(sub)); 01020 for (j = 1; j <= 2; j++) { 01021 NTR_IR_TBL(plus_idx); 01022 IR_OPR(plus_idx) = Plus_Opr; 01023 IR_TYPE_IDX(plus_idx) = CG_INTEGER_DEFAULT_TYPE; 01024 IR_LINE_NUM(plus_idx) = call_line_number; 01025 IR_COL_NUM(plus_idx) = call_col_number; 01026 COPY_OPND(IR_OPND_L(plus_idx), IL_OPND(trp)); 01027 IR_LINE_NUM_L(plus_idx) = call_line_number; 01028 IR_COL_NUM_L(plus_idx) = call_col_number; 01029 COPY_OPND(IR_OPND_R(plus_idx), 01030 linearized_offset[i][k]); 01031 IR_LINE_NUM_R(plus_idx) = call_line_number; 01032 IR_COL_NUM_R(plus_idx) = call_col_number; 01033 01034 IL_FLD(trp) = IR_Tbl_Idx; 01035 IL_IDX(trp) = plus_idx; 01036 trp = IL_NEXT_LIST_IDX(trp); 01037 } 01038 } 01039 else { 01040 NTR_IR_TBL(plus_idx); 01041 IR_OPR(plus_idx) = Plus_Opr; 01042 IR_TYPE_IDX(plus_idx) = CG_INTEGER_DEFAULT_TYPE; 01043 IR_LINE_NUM(plus_idx) = call_line_number; 01044 IR_COL_NUM(plus_idx) = call_col_number; 01045 COPY_OPND(IR_OPND_L(plus_idx), IL_OPND(sub)); 01046 IR_LINE_NUM_L(plus_idx) = call_line_number; 01047 IR_COL_NUM_L(plus_idx) = call_col_number; 01048 COPY_OPND(IR_OPND_R(plus_idx), 01049 linearized_offset[i][k]); 01050 IR_LINE_NUM_R(plus_idx) = call_line_number; 01051 IR_COL_NUM_R(plus_idx) = call_col_number; 01052 01053 IL_FLD(sub) = IR_Tbl_Idx; 01054 IL_IDX(sub) = plus_idx; 01055 } 01056 sub = IL_NEXT_LIST_IDX(sub); 01057 k = k + 1; 01058 } 01059 } 01060 } 01061 break; 01062 01063 01064 case Asg_Opr : 01065 if (TYP_TYPE(IR_TYPE_IDX(idx)) == CRI_Ch_Ptr || 01066 TYP_TYPE(IR_TYPE_IDX(idx)) == CRI_Ptr) { 01067 if ((IR_FLD_R(idx) == CN_Tbl_Idx && 01068 TYP_TYPE(CN_TYPE_IDX(IR_IDX_R(idx))) == Integer) || 01069 (IR_FLD_R(idx) == AT_Tbl_Idx && 01070 AT_OBJ_CLASS(idx) == Data_Obj && 01071 TYP_TYPE(ATD_TYPE_IDX(IR_IDX_R(idx))) == Integer) || 01072 (IR_FLD_R(idx) == IR_Tbl_Idx && 01073 TYP_TYPE(IR_TYPE_IDX(IR_IDX_R(idx))) == Integer)) { 01074 if (inlinable) { 01075 inlinable = FALSE; 01076 PRINTMSG(call_line_number, 01077 1652, 01078 Inline, 01079 call_col_number, 01080 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01081 } 01082 } 01083 } 01084 01085 if (IR_FLD_L(new_root) == CN_Tbl_Idx) { 01086 if (inlinable) { 01087 inlinable = FALSE; 01088 PRINTMSG(call_line_number, 01089 1325, 01090 Inline, 01091 call_col_number, 01092 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01093 } 01094 } 01095 01096 if (IR_FLD_L(new_root) == AT_Tbl_Idx && 01097 AT_OBJ_CLASS(IR_IDX_L(new_root)) == Label) { 01098 if (inlinable) { 01099 inlinable = FALSE; 01100 PRINTMSG(call_line_number, 01101 1331, 01102 Inline, 01103 call_col_number, 01104 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01105 } 01106 } 01107 break; 01108 01109 case User_Code_Start_Opr : 01110 IR_OPR(new_root) = Null_Opr; 01111 break; 01112 01113 case Doall_Cmic_Opr : 01114 if (parallel_region > 0) { 01115 if (inlinable) { 01116 inlinable = FALSE; 01117 PRINTMSG(call_line_number, 01118 1556, 01119 Inline, 01120 call_col_number, 01121 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01122 } 01123 } 01124 break; 01125 01126 case Entry_Opr : 01127 if (strcmp(AT_OBJ_NAME_PTR(pgm_attr_idx), 01128 AT_OBJ_NAME_PTR(IR_IDX_L(idx))) == 0) { 01129 processing_ENTRY_called = TRUE; 01130 IR_OPR(new_root) = Label_Opr; 01131 IR_IDX_L(new_root) = entry_label_attr_idx; 01132 } 01133 else { 01134 /* 01135 ENTRY operations must be cleared out in the 01136 text of the inlined routine. 01137 */ 01138 IR_OPR(new_root) = Null_Opr; 01139 processing_ENTRY_called = FALSE; 01140 next_pgm_idx[npi] = IR_IDX_L(idx); 01141 npi = npi + 1; 01142 } 01143 break; 01144 01145 case Init_Reloc_Opr : 01146 case Init_Opr : 01147 /* 01148 CDIR ID's are completely ignored when a routine is 01149 inlined. CDIR ID's within the callee have no effect 01150 on the CDIR ID lines within the caller. 01151 */ 01152 if (!(IR_FLD_L(idx) == IR_Tbl_Idx && 01153 IR_OPR(IR_IDX_L(idx)) == Implied_Do_Opr)) { 01154 attr_idx = find_left_attr(&IR_OPND_L(idx)); 01155 sb_idx = ATD_STOR_BLK_IDX(attr_idx); 01156 01157 CREATE_ID(name, sb_name[What_Blk], sb_len[What_Blk]); 01158 01159 if (sb_idx != NULL_IDX) { 01160 if (strcmp(SB_NAME_PTR(sb_idx), 01161 (char *)&name.string) == 0) { 01162 IR_OPR(new_root) = Null_Opr; 01163 } 01164 } 01165 } 01166 01167 i = 0; 01168 while (next_pgm_idx[i] != NULL_IDX) { 01169 if (strcmp(AT_OBJ_NAME_PTR(next_pgm_idx[i]), 01170 AT_OBJ_NAME_PTR(pgm_attr_idx)) == 0) { 01171 IR_OPR(new_root) = Null_Opr; 01172 break; 01173 } 01174 01175 i = i + 1; 01176 } 01177 break; 01178 01179 case Not_Opr : 01180 if (IR_FLD_L(idx) == IR_Tbl_Idx && 01181 IR_OPR(IR_IDX_L(idx)) == Argchck_Present_Opr) { 01182 cn_idx = set_up_logical_constant(cnst, 01183 CG_LOGICAL_DEFAULT_TYPE, 01184 FALSE_VALUE, 01185 TRUE); 01186 IR_FLD_L(new_root) = CN_Tbl_Idx; 01187 IR_IDX_L(new_root) = cn_idx; 01188 } 01189 break; 01190 01191 case Use_Opr : 01192 module_attr_idx = IR_IDX_L(idx); 01193 name_idx = NULL_IDX; 01194 01195 /* Check to make sure that this module is available in */ 01196 /* this compile. ATP_MOD_PATH_IDX will be set if the */ 01197 /* module was USEd from a different compilation. */ 01198 /* We know that ATP_IN_CURRENT_COMPILE does not need */ 01199 /* to be set then. Otherwise search the global name */ 01200 /* table to make sure this module was seen during this */ 01201 /* compilation. */ 01202 01203 if (ATP_MOD_PATH_IDX(module_attr_idx) == NULL_IDX && 01204 !srch_global_name_tbl(AT_OBJ_NAME_PTR(module_attr_idx), 01205 AT_NAME_LEN(module_attr_idx), 01206 &name_idx)) { 01207 inlinable = FALSE; 01208 PRINTMSG(call_line_number, 1346, Inline, 01209 call_col_number, 01210 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01211 } 01212 else if (name_idx != NULL_IDX && 01213 GA_DEFINED(GN_ATTR_IDX(name_idx))){ 01214 ATP_IN_CURRENT_COMPILE(module_attr_idx) = TRUE; 01215 } 01216 break; 01217 01218 case Clen_Opr : 01219 if (match != 0 && IR_FLD_L(idx) == AT_Tbl_Idx) { 01220 if (TYP_CHAR_CLASS(ATD_TYPE_IDX(IR_IDX_L(idx))) == 01221 Assumed_Size_Char) { 01222 IR_OPR(new_root) = Int_Opr; 01223 COPY_OPND(IR_OPND_L(new_root), substring_len[match]); 01224 } 01225 } 01226 break; 01227 01228 case Aloc_Opr : 01229 if (match != 0 && 01230 OPND_FLD(actual_opnd[match]) == CN_Tbl_Idx) { 01231 IR_OPR(new_root) = Const_Tmp_Loc_Opr; 01232 COPY_OPND(IR_OPND_L(new_root), actual_opnd[match]); 01233 } 01234 break; 01235 01236 case Loc_Opr : 01237 if (inlinable) { 01238 attr_idx = find_left_attr(&IR_OPND_L(idx)); 01239 if (attr_idx != NULL_IDX && 01240 AT_OBJ_CLASS(attr_idx) == Data_Obj && 01241 ATD_IN_COMMON(attr_idx)) { 01242 inlinable = FALSE; 01243 PRINTMSG(call_line_number, 01244 1358, 01245 Inline, 01246 call_col_number, 01247 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01248 } 01249 01250 if (inlinable) { 01251 if (match != 0 && 01252 OPND_FLD(actual_opnd[match]) == CN_Tbl_Idx) { 01253 inlinable = FALSE; 01254 PRINTMSG(call_line_number, 01255 1437, 01256 Inline, 01257 call_col_number, 01258 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01259 } 01260 } 01261 } 01262 break; 01263 01264 case Numarg_Opr : 01265 if (inlinable) { 01266 inlinable = FALSE; 01267 PRINTMSG(call_line_number, 01268 1329, 01269 Inline, 01270 call_col_number, 01271 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01272 } 01273 break; 01274 01275 case Integer_Cdir_Opr : 01276 if (inlinable) { 01277 inlinable = FALSE; 01278 PRINTMSG(call_line_number, 01279 1409, 01280 Inline, 01281 call_col_number, 01282 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01283 } 01284 break; 01285 01286 case Call_Opr : 01287 if ((AT_OBJ_NAME_PTR(IR_IDX_L(idx)))[0] != '_') { 01288 if (inlinable && 01289 opt_flags.inline_lvl == Inline_Lvl_3 && 01290 !ATP_INLINE_ALWAYS(pgm_attr_idx) && 01291 !inline_in_effect) { 01292 inlinable = FALSE; 01293 PRINTMSG(call_line_number, 01294 1543, 01295 Inline, 01296 call_col_number, 01297 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01298 } 01299 } 01300 break; 01301 01302 case Present_Opr : 01303 if (inlinable) { 01304 inlinable = FALSE; 01305 PRINTMSG(call_line_number, 01306 1327, 01307 Inline, 01308 call_col_number, 01309 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01310 } 01311 break; 01312 01313 case Br_Asg_Opr : 01314 if (inlinable) { 01315 inlinable = FALSE; 01316 PRINTMSG(call_line_number, 01317 1331, 01318 Inline, 01319 call_col_number, 01320 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01321 } 01322 break; 01323 01324 case Return_Opr : 01325 if (IR_IDX_L(idx) != NULL_IDX) { 01326 if (inlinable) { 01327 inlinable = FALSE; 01328 PRINTMSG(call_line_number, 01329 1326, 01330 Inline, 01331 call_col_number, 01332 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01333 } 01334 } 01335 else { 01336 IR_OPR(new_root) = Br_Uncond_Opr; 01337 IR_IDX_R(new_root) = exit_label_attr_idx; 01338 IR_FLD_R(new_root) = AT_Tbl_Idx; 01339 } 01340 break; 01341 } 01342 break; 01343 01344 case AT_Tbl_Idx : 01345 if (AT_OBJ_CLASS(idx) == Data_Obj) { 01346 sb_idx = ATD_STOR_BLK_IDX(idx); 01347 01348 /* 01349 We may need to process the storage block for the pointer. 01350 So, call sb_tree with the pointer to process the storage 01351 block. 01352 */ 01353 if (ATD_CLASS(idx) == CRI__Pointee) { 01354 copy_sbtree(ATD_PTR_IDX(idx), AT_Tbl_Idx); 01355 } 01356 01357 if (inlinable) { 01358 /* 01359 When inlining multi entry functions, we 01360 will not inline the function if any two entries 01361 have the same data type and kind type. The reason 01362 is that the inliner does not create an equivalence 01363 group for the different function results and it 01364 is possible for the user to define the function 01365 result thru a different function result variable 01366 than the one associated with the entry taken. 01367 */ 01368 if (ATD_CLASS(idx) == Function_Result) { 01369 function_attr = NULL_IDX; 01370 01371 if (OPND_FLD(dummy_opnd[0]) == AT_Tbl_Idx) { 01372 function_attr = OPND_IDX(dummy_opnd[0]); 01373 } 01374 01375 if (OPND_FLD(dummy_opnd[1]) == AT_Tbl_Idx && 01376 ATD_CLASS(OPND_IDX(dummy_opnd[1])) == Function_Result) { 01377 function_attr = OPND_IDX(dummy_opnd[1]); 01378 } 01379 01380 if (function_attr != NULL_IDX) { 01381 if (idx != function_attr) { 01382 if (TYP_TYPE(ATD_TYPE_IDX(idx)) == 01383 TYP_TYPE(ATD_TYPE_IDX(function_attr))) { 01384 inlinable = FALSE; 01385 PRINTMSG(call_line_number, 01386 1388, 01387 Inline, 01388 call_col_number, 01389 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01390 } 01391 } 01392 } 01393 } 01394 01395 if (ATD_CLASS(idx) == Dummy_Argument) { 01396 found = FALSE; 01397 for (i = 1; i <= number_of_dummy_args; i++) { 01398 if (OPND_IDX(dummy_opnd[i]) == idx) { 01399 found = TRUE; 01400 break; 01401 } 01402 } 01403 01404 if (processing_ENTRY_called) { 01405 if (!found && !AT_HOST_ASSOCIATED(idx)) { 01406 inlinable = FALSE; 01407 PRINTMSG(call_line_number, 01408 1345, 01409 Inline, 01410 call_col_number, 01411 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01412 } 01413 } 01414 } 01415 01416 if (ATD_CLASS(idx) == Compiler_Tmp && 01417 ATD_TMP_INIT_NOT_DONE(idx)) { 01418 insert_init_stmt_for_tmp(idx); 01419 } 01420 01421 if (ATD_CLASS(idx) == CRI__Pointee && 01422 SB_SCP_IDX(sb_idx) != curr_scp_idx) { 01423 01424 /* we need a new attr in the local scope */ 01425 /* and a new segment in the local scope */ 01426 01427 NTR_ATTR_TBL(new_idx); 01428 COPY_ATTR_NTRY(new_idx, idx); 01429 idx = new_idx; 01430 ADD_ATTR_TO_LOCAL_LIST(idx); 01431 01432 new_blk = ntr_stor_blk_tbl(SB_NAME_PTR(sb_idx), 01433 SB_NAME_LEN(sb_idx), 01434 call_line_number, 01435 call_col_number, 01436 SB_BLK_TYPE(sb_idx)); 01437 01438 COPY_TBL_NTRY(stor_blk_tbl, 01439 new_blk, 01440 sb_idx); 01441 01442 SB_SCP_IDX(new_blk) = curr_scp_idx; 01443 ATD_STOR_BLK_IDX(idx) = new_blk; 01444 } 01445 01446 01447 /* 01448 If the same COMMON block exists 01449 in the caller and the callee, 01450 then an EQUIVALENCE needs to be faked for the two 01451 COMMON blocks in question. 01452 The two blocks will be collapsed into one 01453 block and the EQUIV bit will be set on all 01454 attrs in that block. 01455 */ 01456 if (sb_idx != NULL_IDX && 01457 (SB_BLK_TYPE(sb_idx) == Common || 01458 SB_BLK_TYPE(sb_idx) == Task_Common || 01459 SB_BLK_TYPE(sb_idx) == Threadprivate || 01460 SB_BLK_TYPE(sb_idx) == Static_Named || 01461 SB_BLK_TYPE(sb_idx) == Static_Local || 01462 SB_BLK_TYPE(sb_idx) == Static)) { 01463 01464 if (TYP_TYPE(ATD_TYPE_IDX(idx)) == CRI_Ptr || 01465 TYP_TYPE(ATD_TYPE_IDX(idx)) == CRI_Ch_Ptr) { 01466 inlinable = FALSE; 01467 PRINTMSG(call_line_number, 1359, 01468 Inline, 01469 call_col_number, 01470 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01471 } 01472 01473 if (ATD_PE_ARRAY_IDX(idx) != NULL_IDX) { 01474 inlinable = FALSE; 01475 PRINTMSG(call_line_number, 01476 1613, 01477 Inline, 01478 call_col_number, 01479 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01480 } 01481 01482 if (SB_BLK_TYPE(sb_idx) == Static_Local || 01483 SB_BLK_TYPE(sb_idx) == Static_Named) { 01484 SB_BLK_TYPE(sb_idx) = Common; 01485 } 01486 01487 outer_sb_idx = srch_stor_blk_tbl(SB_NAME_PTR(sb_idx), 01488 SB_NAME_LEN(sb_idx), 01489 curr_scp_idx); 01490 01491 if (outer_sb_idx != NULL_IDX) { 01492 original_idx = idx; 01493 01494 attr_idx = SB_FIRST_ATTR_IDX(outer_sb_idx); 01495 01496 while (attr_idx != NULL_IDX) { 01497 type_idx2 = CG_LOGICAL_DEFAULT_TYPE; 01498 01499 /* 01500 If two objects exactly overlay each other 01501 in the two different COMMON blocks, then 01502 we will use the attr from the caller's 01503 COMMON block. This helps optimization. 01504 */ 01505 01506 if (idx != NULL_IDX && 01507 ATD_OFFSET_FLD(attr_idx) == CN_Tbl_Idx && 01508 ATD_OFFSET_FLD(idx) == CN_Tbl_Idx) { 01509 if (folder_driver( 01510 (char *)&CN_CONST(ATD_OFFSET_IDX(attr_idx)), 01511 CN_TYPE_IDX(ATD_OFFSET_IDX(attr_idx)), 01512 (char *)&CN_CONST(ATD_OFFSET_IDX(idx)), 01513 CN_TYPE_IDX(ATD_OFFSET_IDX(idx)), 01514 folded_const, 01515 &type_idx2, 01516 call_line_number, 01517 call_col_number, 01518 2, 01519 Eq_Opr)) { 01520 } 01521 01522 if (THIS_IS_TRUE(folded_const, type_idx2)) { 01523 if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX && 01524 ATD_ARRAY_IDX(idx) == NULL_IDX) { 01525 if (TYP_LINEAR(ATD_TYPE_IDX(attr_idx)) == 01526 TYP_LINEAR(ATD_TYPE_IDX(idx))) { 01527 idx = attr_idx; 01528 } 01529 } 01530 01531 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX && 01532 ATD_ARRAY_IDX(idx) != NULL_IDX) { 01533 if (TYP_LINEAR(ATD_TYPE_IDX(attr_idx)) == 01534 TYP_LINEAR(ATD_TYPE_IDX(idx)) && 01535 BD_RANK(ATD_ARRAY_IDX(attr_idx)) == 01536 BD_RANK(ATD_ARRAY_IDX(idx))) { 01537 for (i = 1; 01538 i <= BD_RANK(ATD_ARRAY_IDX(idx)); 01539 i++) { 01540 01541 01542 if (BD_XT_FLD(ATD_ARRAY_IDX(attr_idx), i) == CN_Tbl_Idx && 01543 BD_XT_FLD(ATD_ARRAY_IDX(idx), i) == CN_Tbl_Idx) { 01544 01545 if (folder_driver( 01546 (char *)&CN_CONST(BD_XT_IDX(ATD_ARRAY_IDX(attr_idx), i)), 01547 CN_TYPE_IDX(BD_XT_IDX(ATD_ARRAY_IDX(attr_idx), i)), 01548 (char *)&CN_CONST(BD_XT_IDX(ATD_ARRAY_IDX(idx), i)), 01549 CN_TYPE_IDX(BD_XT_IDX(ATD_ARRAY_IDX(idx), i)), 01550 folded_const, 01551 &type_idx2, 01552 call_line_number, 01553 call_col_number, 01554 2, 01555 Eq_Opr)) { 01556 } 01557 01558 if (THIS_IS_TRUE(folded_const, type_idx2)) { 01559 idx = attr_idx; 01560 } 01561 } 01562 01563 01564 } 01565 } 01566 } 01567 } 01568 } 01569 01570 attr_idx = ATD_NEXT_MEMBER_IDX(attr_idx); 01571 } 01572 01573 01574 /* 01575 Increase the length of the caller's storage 01576 segment if the callee's was larger. 01577 */ 01578 if (SB_LEN_FLD(sb_idx) == CN_Tbl_Idx && 01579 SB_LEN_FLD(outer_sb_idx) == CN_Tbl_Idx) { 01580 type_idx2 = CG_LOGICAL_DEFAULT_TYPE; 01581 01582 if (folder_driver( 01583 (char *)&CN_CONST(SB_LEN_IDX(sb_idx)), 01584 CN_TYPE_IDX(SB_LEN_IDX(sb_idx)), 01585 (char *)&CN_CONST(SB_LEN_IDX(outer_sb_idx)), 01586 CN_TYPE_IDX(SB_LEN_IDX(outer_sb_idx)), 01587 folded_const, 01588 &type_idx2, 01589 call_line_number, 01590 call_col_number, 01591 2, 01592 Gt_Opr)) { 01593 } 01594 01595 01596 if (THIS_IS_TRUE(folded_const, type_idx2)) { 01597 if (inlinable && 01598 (strcmp(SB_NAME_PTR(outer_sb_idx), 01599 sb_name[What_Blk]) != 0)) { 01600 01601 SB_LEN_IDX(outer_sb_idx) = SB_LEN_IDX(sb_idx); 01602 PRINTMSG(call_line_number, 01603 1524, 01604 Warning, 01605 call_col_number, 01606 SB_BLANK_COMMON(outer_sb_idx) ? 01607 "" : SB_NAME_PTR(outer_sb_idx), 01608 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01609 } 01610 } 01611 } 01612 01613 if (original_idx == idx) { 01614 SB_DEF_MULT_SCPS(outer_sb_idx) = TRUE; 01615 } 01616 01617 ATD_STOR_BLK_IDX(idx) = outer_sb_idx; 01618 01619 /* PDGCS does not optimize these correctly. */ 01620 if (ATD_POINTER(idx)) { 01621 inlinable = FALSE; 01622 PRINTMSG(call_line_number, 01623 1337, 01624 Inline, 01625 call_col_number, 01626 AT_OBJ_NAME_PTR(pgm_attr_idx)); 01627 } 01628 } 01629 else { /* not found in the caller's scope */ 01630 /* 01631 If this storage block is not in the current 01632 scope, then we need to make a copy of the 01633 storage block and move it into the current 01634 scope. The variable being processed then 01635 becomes part of the newly created storage 01636 block. 01637 */ 01638 if (SB_SCP_IDX(sb_idx) != curr_scp_idx) { 01639 new_blk = ntr_stor_blk_tbl(SB_NAME_PTR(sb_idx), 01640 SB_NAME_LEN(sb_idx), 01641 call_line_number, 01642 call_col_number, 01643 SB_BLK_TYPE(sb_idx)); 01644 01645 COPY_TBL_NTRY(stor_blk_tbl, 01646 new_blk, 01647 sb_idx); 01648 01649 SB_SCP_IDX(new_blk) = curr_scp_idx; 01650 ATD_STOR_BLK_IDX(idx) = new_blk; 01651 } 01652 } 01653 } 01654 } 01655 } 01656 01657 new_root = idx; 01658 break; 01659 01660 case CN_Tbl_Idx : 01661 new_root = idx; 01662 break; 01663 01664 case SH_Tbl_Idx : 01665 new_root = NULL_IDX; 01666 break; 01667 01668 case IL_Tbl_Idx : 01669 trail = NULL_IDX; 01670 while (idx != NULL_IDX) { 01671 NTR_IR_LIST_TBL(list_idx); 01672 COPY_OPND(IL_OPND(list_idx), IL_OPND(idx)); 01673 IL_PREV_LIST_IDX(list_idx) = NULL_IDX; 01674 IL_NEXT_LIST_IDX(list_idx) = NULL_IDX; 01675 01676 if (IL_ARG_DESC_VARIANT(idx)) { 01677 IL_ARG_DESC_VARIANT(list_idx) = TRUE; 01678 IL_ARG_DESC_IDX(list_idx) = IL_ARG_DESC_IDX(idx); 01679 } 01680 else { 01681 IL_PREV_LIST_IDX(list_idx) = trail; 01682 } 01683 01684 if (trail != NULL_IDX) { 01685 IL_NEXT_LIST_IDX(trail) = list_idx; 01686 } 01687 else { 01688 new_root = list_idx; 01689 } 01690 01691 IL_PE_SUBSCRIPT(list_idx) = IL_PE_SUBSCRIPT(idx); 01692 01693 new_idx = copy_sbtree(IL_IDX(idx), IL_FLD(idx)); 01694 IL_IDX(list_idx) = new_idx; 01695 01696 if (IL_FLD(idx) == AT_Tbl_Idx) { 01697 for (i = 0; i <= number_of_dummy_args; i++) { 01698 if (IL_IDX(idx) == OPND_IDX(dummy_opnd[i])) { 01699 if (OPND_FLD(actual_opnd[i]) == AT_Tbl_Idx && 01700 ATD_AUTOMATIC(OPND_IDX(actual_opnd[i]))) { 01701 COPY_OPND(IL_OPND(list_idx), actual_opnd[i]); 01702 } 01703 else if (OPND_IDX(struct_tree[i]) != NULL_IDX) { 01704 COPY_OPND(IL_OPND(list_idx), struct_tree[i]); 01705 } 01706 else { 01707 COPY_OPND(IL_OPND(list_idx), actual_opnd[i]); 01708 } 01709 } 01710 } 01711 01712 if (AT_OBJ_CLASS(IL_IDX(idx)) == Label) { 01713 for (k = 0; k < next_label_slot; k++) { 01714 if (IL_IDX(idx) == old_label[k]) { 01715 break; 01716 } 01717 } 01718 01719 if (k < next_label_slot) { 01720 IL_IDX(list_idx) = new_label[k]; 01721 IL_FLD(list_idx) = AT_Tbl_Idx; 01722 } 01723 else { 01724 old_label[next_label_slot] = IL_IDX(idx); 01725 new_label_attr = gen_internal_lbl(call_line_number); 01726 COPY_COMMON_ATTR_INFO(IL_IDX(idx), 01727 new_label_attr, 01728 Label); 01729 COPY_VARIANT_ATTR_INFO(IL_IDX(idx), 01730 new_label_attr, 01731 Label); 01732 AT_ATTR_LINK(new_label_attr) = NULL_IDX; 01733 new_label[next_label_slot] = new_label_attr; 01734 01735 IL_IDX(list_idx) = new_label_attr; 01736 IL_FLD(list_idx) = AT_Tbl_Idx; 01737 01738 if (ATL_DIRECTIVE_LIST(new_label_attr) != NULL_IDX) { 01739 il_idx = IL_IDX(ATL_DIRECTIVE_LIST(new_label_attr)) + 01740 Cache_Bypass_Dir_Idx; 01741 01742 if (IL_FLD(il_idx) == IL_Tbl_Idx) { 01743 il_idx = IL_IDX(il_idx); 01744 01745 while (il_idx != NULL_IDX) { 01746 for (i = 1; i <= number_of_dummy_args; i++) { 01747 if (OPND_IDX(dummy_opnd[i]) == 01748 IL_IDX(il_idx)) { 01749 IL_IDX(il_idx)=OPND_IDX(actual_opnd[i]); 01750 break; 01751 } 01752 } 01753 01754 il_idx = IL_NEXT_LIST_IDX(il_idx); 01755 } 01756 } 01757 } 01758 01759 next_label_slot = next_label_slot + 1; 01760 if (next_label_slot == MAX_INLINE_LABELS) { 01761 next_label_slot = next_label_slot - 1; 01762 inlinable = FALSE; 01763 table_overflow = TRUE; 01764 } 01765 } 01766 } 01767 } 01768 01769 if (IL_FLD(idx) != IL_Tbl_Idx) { 01770 IL_LINE_NUM(list_idx) = call_line_number; 01771 IL_COL_NUM(list_idx) = call_col_number; 01772 } 01773 01774 trail = list_idx; 01775 idx = IL_NEXT_LIST_IDX(idx); 01776 } 01777 break; 01778 } 01779 } 01780 01781 01782 TRACE (Func_Exit, "copy_sbtree", NULL); 01783 01784 return(new_root); 01785 01786 } /* copy_sbtree */ 01787 01788 01789 01790 01791 /******************************************************************************\ 01792 |* *| 01793 |* Description: *| 01794 |* This routine is the driver to create a copy of the called routine. *| 01795 |* A copy is created from the template of the routine. *| 01796 |* *| 01797 |* *| 01798 |* Input parameters: *| 01799 |* NONE *| 01800 |* *| 01801 |* Output parameters: *| 01802 |* NONE *| 01803 |* *| 01804 |* Returns: *| 01805 |* NOTHING *| 01806 |* *| 01807 \******************************************************************************/ 01808 void make_copy_of_routine(int original_head) 01809 01810 { 01811 int copy_trail; 01812 int original_sh; 01813 int new_sh; 01814 int new_ir; 01815 01816 TRACE (Func_Entry, "make_copy_of_routine", NULL); 01817 copy_head = NULL_IDX; 01818 01819 original_sh = original_head; 01820 copy_trail = copy_head; 01821 01822 while (original_sh != NULL_IDX) { 01823 new_sh = ntr_sh_tbl(); 01824 if (copy_head == NULL_IDX) { 01825 copy_head = new_sh; 01826 } 01827 COPY_TBL_NTRY(sh_tbl, new_sh, original_sh); 01828 SH_NEXT_IDX(new_sh) = NULL_IDX; 01829 SH_PREV_IDX(new_sh) = NULL_IDX; 01830 SH_GLB_LINE(new_sh) = call_line_number; 01831 SH_COL_NUM(new_sh) = call_col_number; 01832 new_ir = copy_sbtree(SH_IR_IDX(original_sh), IR_Tbl_Idx); 01833 sh_count = sh_count + 1; 01834 SH_IR_IDX(new_sh) = new_ir; 01835 01836 SH_PREV_IDX(new_sh) = copy_trail; 01837 if (SH_PREV_IDX(new_sh) != NULL_IDX) { 01838 SH_NEXT_IDX(SH_PREV_IDX(new_sh)) = new_sh; 01839 } 01840 copy_trail = new_sh; 01841 original_sh = SH_NEXT_IDX(original_sh); 01842 } 01843 01844 TRACE (Func_Exit, "make_copy_of_routine", NULL); 01845 01846 return; 01847 01848 } /* make_copy_of_routine */ 01849 01850 01851 01852 01853 01854 01855 /******************************************************************************\ 01856 |* *| 01857 |* Description: *| 01858 |* *| 01859 |* Input parameters: *| 01860 |* NONE *| 01861 |* *| 01862 |* Output parameters: *| 01863 |* NONE *| 01864 |* *| 01865 |* Returns: *| 01866 |* NOTHING *| 01867 |* *| 01868 \******************************************************************************/ 01869 void srch_for_calls(int ir_idx, 01870 fld_type field) 01871 { 01872 01873 id_str_type stor_name; 01874 int actual_arg_list_idx; 01875 int new_darg_attr; 01876 int struct_base_attr_idx = NULL_IDX; 01877 int copy_in_sh; 01878 int idx; 01879 int sub; 01880 int list_idx; 01881 int list_idx1; 01882 int list_idx2; 01883 int attr_idx; 01884 int type_idx; 01885 int loc_idx; 01886 fld_type loc_fld; 01887 int based_blk; 01888 int div_idx; 01889 int asg_idx; 01890 int new_idx; 01891 int al_idx; 01892 int tmp_al_idx; 01893 int flipped_bd_idx; 01894 int dummy_bd_idx; 01895 int actual_bd_idx; 01896 int tmp_attr; 01897 int tmp_sh; 01898 int minus_idx; 01899 int i; 01900 int j; 01901 int k; 01902 int l; 01903 int line; 01904 int col; 01905 int copy_out_array_element; 01906 int copy_out_DV_scalar; 01907 opnd_type opnd; 01908 boolean name_substitution; 01909 boolean call_by_value; 01910 boolean dummy_modified; 01911 boolean dummy_referenced; 01912 01913 01914 TRACE (Func_Entry, "srch_for_calls", NULL); 01915 01916 switch (field) { 01917 case NO_Tbl_Idx : 01918 break; 01919 01920 case AT_Tbl_Idx : 01921 break; 01922 01923 case IR_Tbl_Idx : 01924 switch (IR_OPR(ir_idx)) { 01925 case Noinline_Cdir_Opr : 01926 noinline_in_effect = TRUE; 01927 inline_in_effect = FALSE; 01928 break; 01929 01930 case Inline_Cdir_Opr : 01931 noinline_in_effect = FALSE; 01932 inline_in_effect = TRUE; 01933 break; 01934 01935 case Call_Opr : 01936 call_line_number = IR_LINE_NUM_L(SH_IR_IDX(call_sh)); 01937 call_col_number = IR_COL_NUM_L(SH_IR_IDX(call_sh)); 01938 01939 next_label_slot = 0; 01940 pgm_attr_idx = IR_IDX_L(ir_idx); 01941 01942 /* 01943 Starting processing for a new Call_Opr in the 01944 IR stream. Clean up everything. Clear out 01945 all the tables. 01946 */ 01947 if (ATP_PROC(pgm_attr_idx) != Intrin_Proc && 01948 !SH_INLINING_ATTEMPTED(call_sh) && 01949 AT_OBJ_NAME(pgm_attr_idx) != '$' && 01950 AT_OBJ_NAME(pgm_attr_idx) != '_') { 01951 inlinable = !table_overflow; 01952 SH_INLINING_ATTEMPTED(call_sh) = TRUE; 01953 next_copy_out_sh_idx = 0; 01954 01955 for (i = 0; i <= 8; i++) { 01956 subscript[i] = null_opnd; 01957 subscript_attr[i] = null_opnd; 01958 } 01959 01960 for (i = 0; i <= MAX_INLINE_ARGS-1; i++) { 01961 copy_out_sh[i] = NULL_IDX; 01962 actual_arg_attrs[i] = NULL_IDX; 01963 flipped_opnd[i] = null_opnd; 01964 actual_opnd[i] = null_opnd; 01965 dummy_opnd[i] = null_opnd; 01966 struct_tree[i] = null_opnd; 01967 subscripting_tree[i] = null_opnd; 01968 substringing_tree[i] = null_opnd; 01969 OPND_IDX(substring_offset[i]) = CN_INTEGER_ZERO_IDX; 01970 OPND_FLD(substring_offset[i]) = CN_Tbl_Idx; 01971 for (k = 0; k <= 8; k++) { 01972 OPND_IDX(linearized_offset[i][k]) = CN_INTEGER_ZERO_IDX; 01973 OPND_FLD(linearized_offset[i][k]) = CN_Tbl_Idx; 01974 } 01975 01976 } 01977 01978 number_of_actual_args = IR_LIST_CNT_R(ir_idx); 01979 01980 if (cmd_line_flags.runtime_argument || 01981 cmd_line_flags.runtime_arg_call || 01982 cmd_line_flags.runtime_arg_count_only) { 01983 number_of_actual_args = number_of_actual_args - 1; 01984 } 01985 01986 /* 01987 This check here is a saftey valve. Table sizes 01988 are checked here. If we are approaching dangerous limits, 01989 we just stop inlining. The values are arbitrary. 01990 */ 01991 if (attr_list_tbl_idx > 60536) { /* 2 ** 16 - 5000 */ 01992 inlinable = FALSE; 01993 PRINTMSG(call_line_number, 01994 1202, 01995 Inline, 01996 call_col_number, 01997 AT_OBJ_NAME_PTR(pgm_attr_idx), 01998 "internal table(s) almost full"); 01999 } 02000 02001 if (inlinable && ATP_PROC(pgm_attr_idx) == Dummy_Proc) { 02002 inlinable = FALSE; 02003 PRINTMSG(call_line_number, 02004 1333, 02005 Inline, 02006 call_col_number, 02007 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02008 } 02009 02010 if (inlinable && ATP_ELEMENTAL(pgm_attr_idx)) { 02011 inlinable = FALSE; 02012 PRINTMSG(call_line_number, 02013 1657, 02014 Inline, 02015 call_col_number, 02016 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02017 } 02018 02019 if (inlinable && ATP_FIRST_SH_IDX(pgm_attr_idx) == NULL_IDX) { 02020 02021 if (! find_prog_unit_tbl(pgm_attr_idx)) { 02022 inlinable = FALSE; 02023 if (ATP_PROC(pgm_attr_idx) == Module_Proc) { 02024 PRINTMSG(call_line_number, 02025 1495, 02026 Inline, 02027 call_col_number, 02028 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02029 } 02030 else { 02031 PRINTMSG(call_line_number, 02032 1344, 02033 Inline, 02034 call_col_number, 02035 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02036 } 02037 } 02038 else { 02039 if (ATP_PGM_UNIT(pgm_attr_idx) == Function && 02040 ATP_PGM_UNIT(AT_ATTR_LINK(pgm_attr_idx)) == Function && 02041 ATP_RSLT_IDX(pgm_attr_idx) != NULL_IDX && 02042 ATP_RSLT_IDX(AT_ATTR_LINK(pgm_attr_idx)) != NULL_IDX && 02043 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(pgm_attr_idx))) != 02044 TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX( 02045 AT_ATTR_LINK(pgm_attr_idx))))) { 02046 inlinable = FALSE; 02047 PRINTMSG(call_line_number, 02048 1425, 02049 Inline, 02050 call_col_number, 02051 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02052 } 02053 else { 02054 ATP_FIRST_SH_IDX(pgm_attr_idx) = 02055 ATP_FIRST_SH_IDX(AT_ATTR_LINK(pgm_attr_idx)); 02056 02057 ATP_RSLT_IDX(pgm_attr_idx) = 02058 ATP_RSLT_IDX(AT_ATTR_LINK(pgm_attr_idx)); 02059 02060 ATP_NUM_DARGS(pgm_attr_idx) = 02061 ATP_NUM_DARGS(AT_ATTR_LINK(pgm_attr_idx)); 02062 02063 ATP_FIRST_IDX(pgm_attr_idx) = 02064 ATP_FIRST_IDX(AT_ATTR_LINK(pgm_attr_idx)); 02065 02066 ATP_INLINE_NEVER(pgm_attr_idx) = 02067 ATP_INLINE_NEVER(pgm_attr_idx) || 02068 ATP_INLINE_NEVER(AT_ATTR_LINK(pgm_attr_idx)); 02069 02070 ATP_RECURSIVE(pgm_attr_idx) = 02071 ATP_RECURSIVE(pgm_attr_idx) || 02072 ATP_RECURSIVE(AT_ATTR_LINK(pgm_attr_idx)); 02073 02074 ATP_INLINE_ALWAYS(pgm_attr_idx) = 02075 ATP_INLINE_ALWAYS(pgm_attr_idx) || 02076 ATP_INLINE_ALWAYS(AT_ATTR_LINK(pgm_attr_idx)); 02077 02078 ATP_HAS_TASK_DIRS(SCP_ATTR_IDX(curr_scp_idx)) = 02079 ATP_HAS_TASK_DIRS(pgm_attr_idx) || 02080 ATP_HAS_TASK_DIRS(AT_ATTR_LINK(pgm_attr_idx)) || 02081 ATP_HAS_TASK_DIRS(SCP_ATTR_IDX(curr_scp_idx)); 02082 02083 ATP_HAS_OVER_INDEXING(SCP_ATTR_IDX(curr_scp_idx)) = 02084 ATP_HAS_OVER_INDEXING(pgm_attr_idx) || 02085 ATP_HAS_OVER_INDEXING(AT_ATTR_LINK(pgm_attr_idx)) || 02086 ATP_HAS_OVER_INDEXING(SCP_ATTR_IDX(curr_scp_idx)); 02087 02088 AT_ATTR_LINK(pgm_attr_idx) = NULL_IDX; 02089 } 02090 } 02091 } 02092 02093 number_of_dummy_args = ATP_NUM_DARGS(pgm_attr_idx); 02094 02095 /* 02096 The FUNCTION result gets stuffed into the 0th element. 02097 Otherwise, the 0th element is empty. 02098 */ 02099 if (function_call) { 02100 idx = SH_IR_IDX(call_sh); 02101 COPY_OPND(actual_opnd[0], IR_OPND_L(idx)); 02102 OPND_IDX(dummy_opnd[0]) = ATP_RSLT_IDX(pgm_attr_idx); 02103 OPND_FLD(dummy_opnd[0]) = AT_Tbl_Idx; 02104 } 02105 02106 if (inlinable && opt_flags.inline_lvl == Inline_Lvl_1) { 02107 if (!ATP_INLINE_ALWAYS(pgm_attr_idx) && 02108 !inline_in_effect) { 02109 inlinable = FALSE; 02110 PRINTMSG(call_line_number, 02111 1335, 02112 Inline, 02113 call_col_number, 02114 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02115 } 02116 } 02117 02118 if (inlinable && opt_flags.inline_lvl == Inline_Lvl_2) { 02119 if (!ATP_INLINE_ALWAYS(pgm_attr_idx) && 02120 !inline_in_effect && 02121 loop_nest <= 0) { 02122 inlinable = FALSE; 02123 PRINTMSG(call_line_number, 02124 1336, 02125 Inline, 02126 call_col_number, 02127 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02128 } 02129 } 02130 02131 if (inlinable && noinline_in_effect) { 02132 inlinable = FALSE; 02133 PRINTMSG(call_line_number, 02134 1338, 02135 Inline, 02136 call_col_number, 02137 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02138 } 02139 02140 if (inlinable && ATP_INLINE_NEVER(pgm_attr_idx)) { 02141 inlinable = FALSE; 02142 PRINTMSG(call_line_number, 02143 1339, 02144 Inline, 02145 call_col_number, 02146 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02147 } 02148 02149 if (inlinable && (number_of_dummy_args != number_of_actual_args)) { 02150 inlinable = FALSE; 02151 PRINTMSG(call_line_number, 02152 1342, 02153 Inline, 02154 call_col_number, 02155 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02156 } 02157 02158 if (inlinable && (number_of_actual_args >= MAX_INLINE_ARGS)) { 02159 inlinable = FALSE; 02160 PRINTMSG(call_line_number, 02161 1343, 02162 Inline, 02163 call_col_number, 02164 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02165 } 02166 02167 if (inlinable && ATP_RECURSIVE(pgm_attr_idx)) { 02168 inlinable = FALSE; 02169 PRINTMSG(call_line_number, 02170 1332, 02171 Inline, 02172 call_col_number, 02173 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02174 } 02175 02176 if (OPND_IDX(dummy_opnd[0]) != NULL_IDX && 02177 inlinable && AT_HOST_ASSOCIATED(OPND_IDX(dummy_opnd[0]))) { 02178 inlinable = FALSE; 02179 PRINTMSG(call_line_number, 02180 1357, 02181 Inline, 02182 call_col_number, 02183 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02184 } 02185 02186 actual_arg_list_idx = IR_IDX_R(ir_idx); 02187 for (k = 1; k <= number_of_actual_args; k++) { 02188 attr_idx = find_base_attr(&IL_OPND(actual_arg_list_idx), 02189 &line, 02190 &col); 02191 actual_arg_attrs[k] = attr_idx; 02192 actual_arg_list_idx = IL_NEXT_LIST_IDX(actual_arg_list_idx); 02193 } 02194 02195 /* 02196 This WHILE loop processes all the actual arguments in the 02197 actual arg list hanging off the Call_Opr. 02198 */ 02199 i = 1; 02200 j = ATP_FIRST_IDX(pgm_attr_idx); 02201 actual_arg_list_idx = IR_IDX_R(ir_idx); 02202 while (actual_arg_list_idx != NULL_IDX && 02203 number_of_actual_args > 0 && 02204 inlinable && 02205 i <= number_of_actual_args) { 02206 copy_out_array_element = NULL_IDX; 02207 copy_out_DV_scalar = NULL_IDX; 02208 02209 OPND_IDX(dummy_opnd[i]) = SN_ATTR_IDX(j); 02210 OPND_FLD(dummy_opnd[i]) = AT_Tbl_Idx; 02211 02212 /* 02213 Determine if the dummy argument every gets modified 02214 by the inlined code. 02215 */ 02216 dummy_modified = AT_DEFINED(SN_ATTR_IDX(j)) || 02217 AT_ACTUAL_ARG(SN_ATTR_IDX(j)) || 02218 AT_DEF_IN_CHILD(SN_ATTR_IDX(j)); 02219 02220 if (AT_OBJ_CLASS(SN_ATTR_IDX(j)) == Data_Obj && 02221 ATD_INTENT(SN_ATTR_IDX(j)) == Intent_In) { 02222 dummy_modified = FALSE; 02223 } 02224 02225 dummy_referenced = AT_REFERENCED(SN_ATTR_IDX(j)) == Referenced; 02226 02227 if (AT_OBJ_CLASS(SN_ATTR_IDX(j)) == Data_Obj && 02228 ATD_INTENT(SN_ATTR_IDX(j)) == Intent_Out) { 02229 dummy_referenced = FALSE; 02230 } 02231 02232 /* 02233 If we have a derived type containing dope vectors, some 02234 initialization of the DV may have occured. We cannot 02235 assume Intent_Out. 02236 */ 02237 if (AT_OBJ_CLASS(SN_ATTR_IDX(j)) == Data_Obj && 02238 TYP_TYPE(ATD_TYPE_IDX(SN_ATTR_IDX(j))) == Structure) { 02239 dummy_referenced = TRUE; 02240 } 02241 02242 if (inlinable && AT_HOST_ASSOCIATED(OPND_IDX(dummy_opnd[i]))) { 02243 inlinable = FALSE; 02244 PRINTMSG(call_line_number, 02245 1341, 02246 Inline, 02247 call_col_number, 02248 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02249 } 02250 02251 if (inlinable && AT_OPTIONAL(OPND_IDX(dummy_opnd[i]))) { 02252 inlinable = FALSE; 02253 PRINTMSG(call_line_number, 02254 1334, 02255 Inline, 02256 call_col_number, 02257 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02258 } 02259 02260 if (inlinable) { 02261 if (AT_OBJ_CLASS(OPND_IDX(dummy_opnd[i])) != Data_Obj) { 02262 inlinable = FALSE; 02263 PRINTMSG(call_line_number, 02264 1340, 02265 Inline, 02266 call_col_number, 02267 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02268 break; 02269 } 02270 else { /* we have a Data_Obj */ 02271 if (TYP_TYPE(ATD_TYPE_IDX(SN_ATTR_IDX(j))) == CRI_Ptr || 02272 TYP_TYPE(ATD_TYPE_IDX(SN_ATTR_IDX(j))) == CRI_Ch_Ptr) { 02273 inlinable = FALSE; 02274 PRINTMSG(call_line_number, 02275 1355, 02276 Inline, 02277 call_col_number, 02278 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02279 } 02280 02281 if (ATD_PE_ARRAY_IDX(OPND_IDX(dummy_opnd[i])) !=NULL_IDX) { 02282 inlinable = FALSE; 02283 PRINTMSG(call_line_number, 02284 1601, 02285 Inline, 02286 call_col_number, 02287 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02288 } 02289 } 02290 } 02291 02292 call_by_value = FALSE; 02293 if (IL_FLD(actual_arg_list_idx) == IR_Tbl_Idx && 02294 (IR_OPR(IL_IDX(actual_arg_list_idx)) == Aloc_Opr || 02295 IR_OPR(IL_IDX(actual_arg_list_idx)) == Const_Tmp_Loc_Opr)) { 02296 COPY_OPND(actual_opnd[i], 02297 IR_OPND_L(IL_IDX(actual_arg_list_idx))); 02298 } 02299 else { 02300 COPY_OPND(actual_opnd[i], IL_OPND(actual_arg_list_idx)); 02301 02302 /* 02303 The only time there should be an AT passed as 02304 an actual argument is when it is call by value. 02305 */ 02306 if (OPND_FLD(actual_opnd[i]) == AT_Tbl_Idx) { 02307 call_by_value = TRUE; 02308 } 02309 } 02310 02311 /* 02312 This IF is for mapping dope-vector based scalar 02313 actual arguments to scalar dummy arguments. 02314 02315 COMPLEX CPOINTER, COMPLEX1 02316 POINTER CPOINTER 02317 TARGET COMPLEX1 02318 02319 CPOINTER => COMPLEX1 02320 CPOINTER = (-100,100) 02321 CALL ASSGN(CPOINTER) 02322 PRINT*, CPOINTER 02323 END 02324 02325 SUBROUTINE ASSGN(COMPLEX1) 02326 COMPLEX COMPLEX1 02327 COMPLEX1 = (-1,-1) 02328 END 02329 */ 02330 if (inlinable && 02331 OPND_FLD(actual_opnd[i]) == IR_Tbl_Idx && 02332 IR_OPR(OPND_IDX(actual_opnd[i])) == Dv_Access_Base_Addr && 02333 ATD_ARRAY_IDX(OPND_IDX(dummy_opnd[i])) == NULL_IDX) { 02334 scalar_dope_to_scalar(i, 02335 ©_out_DV_scalar, 02336 dummy_referenced); 02337 } 02338 02339 02340 /* 02341 This IF is for processing an array element actual 02342 argument mapped to a scalar dummy argument. 02343 before inlining: 02344 PROGRAM C 02345 DIMENSION A(10) 02346 COMMON // I 02347 I = 4 02348 CALL SAM(A(I)) 02349 END 02350 02351 SUBROUTINE SAM(S) 02352 COMMON // I 02353 S = S + 5.0 02354 I = I + 1 02355 END 02356 after inlining: 02357 PROGRAM C 02358 DIMENSION A(10) 02359 t$1 = I 02360 t$2 = A(I) 02361 t$2 = t$2 + 5.0 02362 I = I + 1 02363 A(t$1) = t$2 02364 END 02365 */ 02366 if (inlinable && 02367 OPND_FLD(actual_opnd[i]) == IR_Tbl_Idx && 02368 IR_OPR(OPND_IDX(actual_opnd[i])) == Subscript_Opr && 02369 ATD_ARRAY_IDX(OPND_IDX(dummy_opnd[i])) == NULL_IDX) { 02370 array_element_to_scalar(i, 02371 ©_out_array_element, 02372 dummy_referenced, 02373 dummy_modified); 02374 02375 } 02376 02377 /* 02378 This IF block processes character mappings. 02379 */ 02380 if (inlinable && 02381 OPND_FLD(actual_opnd[i]) == IR_Tbl_Idx && 02382 (IR_OPR(OPND_IDX(actual_opnd[i])) == Whole_Substring_Opr || 02383 IR_OPR(OPND_IDX(actual_opnd[i])) == Substring_Opr)) { 02384 character_to_character(i); 02385 } 02386 02387 /* 02388 This IF block processes structure mappings. 02389 */ 02390 if (inlinable && 02391 OPND_FLD(actual_opnd[i]) == IR_Tbl_Idx && 02392 IR_OPR(OPND_IDX(actual_opnd[i])) == Struct_Opr) { 02393 COPY_OPND(struct_tree[i], actual_opnd[i]); 02394 02395 struct_base_attr_idx = find_base_attr(&actual_opnd[i], 02396 &line, 02397 &col); 02398 02399 COPY_OPND(actual_opnd[i], 02400 IR_OPND_L(OPND_IDX(actual_opnd[i]))); 02401 } 02402 02403 if ((call_by_value && inlinable) || 02404 (OPND_FLD(actual_opnd[i]) == IR_Tbl_Idx && 02405 inlinable && 02406 (IR_OPR(OPND_IDX(actual_opnd[i])) == Dv_Access_Base_Addr || 02407 IR_OPR(OPND_IDX(actual_opnd[i])) == Subscript_Opr))) { 02408 COPY_OPND(subscripting_tree[i], actual_opnd[i]); 02409 new_darg_attr = gen_compiler_tmp(call_line_number, 02410 call_col_number, 02411 Priv, TRUE); 02412 02413 attr_idx = find_base_attr(&actual_opnd[i], 02414 &line, 02415 &col); 02416 02417 if (struct_base_attr_idx != NULL_IDX) { 02418 attr_idx = struct_base_attr_idx; 02419 } 02420 02421 OPND_IDX(flipped_opnd[i]) = attr_idx; 02422 OPND_FLD(flipped_opnd[i]) = AT_Tbl_Idx; 02423 OPND_IDX(actual_opnd[i]) = attr_idx; 02424 OPND_FLD(actual_opnd[i]) = AT_Tbl_Idx; 02425 02426 name_substitution = 02427 check_actual_and_dummy(actual_opnd[i], dummy_opnd[i], i); 02428 02429 /* 02430 If the call list contains more than one referenced to 02431 the same array, name substitution will NOT be performed. 02432 eg. 02433 call sam(A(4), A(8), B(1)) 02434 */ 02435 for (k = 1; k <= number_of_actual_args; k++) { 02436 if (k != i && 02437 OPND_IDX(actual_opnd[i]) == actual_arg_attrs[k]) { 02438 name_substitution = FALSE; 02439 } 02440 } 02441 02442 /* 02443 Save away the expressions that will be used to linearize 02444 the references to the corresponding dummy arguments in 02445 the inlined code. 02446 */ 02447 02448 if (name_substitution) { 02449 actual_bd_idx = ATD_ARRAY_IDX(OPND_IDX(actual_opnd[i])); 02450 sub = IR_IDX_R(OPND_IDX(subscripting_tree[i])); 02451 k = 1; 02452 while (sub != NULL_IDX) { 02453 NTR_IR_TBL(minus_idx); 02454 IR_OPR(minus_idx) = Minus_Opr; 02455 IR_TYPE_IDX(minus_idx) = CG_INTEGER_DEFAULT_TYPE; 02456 IR_LINE_NUM(minus_idx) = call_line_number; 02457 IR_COL_NUM(minus_idx) = call_col_number; 02458 COPY_OPND(IR_OPND_L(minus_idx), IL_OPND(sub)); 02459 IR_LINE_NUM_L(minus_idx) = call_line_number; 02460 IR_COL_NUM_L(minus_idx) = call_col_number; 02461 IR_IDX_R(minus_idx) = BD_LB_IDX(actual_bd_idx, k); 02462 IR_FLD_R(minus_idx) = BD_LB_FLD(actual_bd_idx, k); 02463 IR_LINE_NUM_R(minus_idx) = call_line_number; 02464 IR_COL_NUM_R(minus_idx) = call_col_number; 02465 OPND_IDX(linearized_offset[i][k]) = minus_idx; 02466 OPND_FLD(linearized_offset[i][k]) = IR_Tbl_Idx; 02467 02468 sub = IL_NEXT_LIST_IDX(sub); 02469 k = k + 1; 02470 } 02471 } 02472 02473 /* 02474 Insert the Copy_In_Opr prior to the expanded code. 02475 Insert the Copy_Out_Opr after the expanded code. 02476 */ 02477 copy_in_sh = call_sh; 02478 if (!name_substitution && inlinable && 02479 OPND_FLD(subscripting_tree[i]) == IR_Tbl_Idx && 02480 IR_OPR(OPND_IDX(subscripting_tree[i])) == Subscript_Opr) { 02481 NTR_IR_TBL(asg_idx); 02482 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 02483 IR_OPR(asg_idx) = Copy_In_Opr; 02484 IR_LINE_NUM(asg_idx) = call_line_number; 02485 IR_COL_NUM(asg_idx) = call_col_number; 02486 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 02487 IR_IDX_L(asg_idx) = new_darg_attr; 02488 IR_FLD_R(asg_idx) = OPND_FLD(subscripting_tree[i]); 02489 IR_IDX_R(asg_idx) = OPND_IDX(subscripting_tree[i]); 02490 IR_LINE_NUM_L(asg_idx) = call_line_number; 02491 IR_COL_NUM_L(asg_idx) = call_col_number; 02492 IR_LINE_NUM_R(asg_idx) = call_line_number; 02493 IR_COL_NUM_R(asg_idx) = call_col_number; 02494 02495 curr_stmt_sh_idx = call_sh; 02496 gen_sh(Before, 02497 Assignment_Stmt, 02498 call_line_number, 02499 call_col_number, 02500 FALSE, 02501 FALSE, 02502 TRUE); 02503 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 02504 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 02505 copy_in_sh = SH_PREV_IDX(curr_stmt_sh_idx); 02506 02507 NTR_IR_TBL(asg_idx); 02508 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 02509 IR_OPR(asg_idx) = Copy_Out_Opr; 02510 IR_LINE_NUM(asg_idx) = call_line_number; 02511 IR_COL_NUM(asg_idx) = call_col_number; 02512 IR_FLD_L(asg_idx) = OPND_FLD(subscripting_tree[i]); 02513 IR_IDX_L(asg_idx) = OPND_IDX(subscripting_tree[i]); 02514 IR_FLD_R(asg_idx) = AT_Tbl_Idx; 02515 IR_IDX_R(asg_idx) = new_darg_attr; 02516 IR_LINE_NUM_L(asg_idx) = call_line_number; 02517 IR_COL_NUM_L(asg_idx) = call_col_number; 02518 IR_LINE_NUM_R(asg_idx) = call_line_number; 02519 IR_COL_NUM_R(asg_idx) = call_col_number; 02520 02521 curr_stmt_sh_idx = SH_NEXT_IDX(call_sh); 02522 gen_sh(Before, 02523 Assignment_Stmt, 02524 call_line_number, 02525 call_col_number, 02526 FALSE, 02527 FALSE, 02528 TRUE); 02529 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 02530 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 02531 } 02532 02533 tmp_attr = gen_compiler_tmp(call_line_number, 02534 call_col_number, 02535 Priv, TRUE); 02536 02537 ATD_STOR_BLK_IDX(tmp_attr) = SCP_SB_STACK_IDX(curr_scp_idx); 02538 AT_SEMANTICS_DONE(tmp_attr) = TRUE; 02539 AT_DEFINED(tmp_attr) = TRUE; 02540 02541 if (TYP_TYPE(ATD_TYPE_IDX(OPND_IDX(dummy_opnd[i]))) == 02542 Character) { 02543 ATD_TYPE_IDX(tmp_attr) = CRI_Ch_Ptr_8; 02544 02545 if (TYP_CHAR_CLASS(ATD_TYPE_IDX(OPND_IDX(dummy_opnd[i]))) 02546 == Assumed_Size_Char && 02547 OPND_FLD(subscripting_tree[i]) == IR_Tbl_Idx && 02548 IR_OPR(OPND_IDX(subscripting_tree[i])) == 02549 Dv_Access_Base_Addr) { 02550 NTR_IR_TBL(asg_idx); 02551 IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE; 02552 IR_OPR(asg_idx) = Dv_Access_El_Len; 02553 IR_LINE_NUM(asg_idx) = call_line_number; 02554 IR_COL_NUM(asg_idx) = call_col_number; 02555 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 02556 IR_IDX_L(asg_idx) = 02557 IR_IDX_L(OPND_IDX(subscripting_tree[i])); 02558 IR_LINE_NUM_L(asg_idx) = call_line_number; 02559 IR_COL_NUM_L(asg_idx) = call_col_number; 02560 02561 NTR_IR_TBL(div_idx); 02562 IR_TYPE_IDX(div_idx) = CG_INTEGER_DEFAULT_TYPE; 02563 IR_OPR(div_idx) = Shiftr_Opr; 02564 IR_LINE_NUM(div_idx) = call_line_number; 02565 IR_COL_NUM(div_idx) = call_col_number; 02566 IR_FLD_L(div_idx) = IR_Tbl_Idx; 02567 IR_IDX_L(div_idx) = asg_idx; 02568 IR_LINE_NUM_L(div_idx) = call_line_number; 02569 IR_COL_NUM_L(div_idx) = call_col_number; 02570 IR_FLD_R(div_idx) = CN_Tbl_Idx; 02571 IR_IDX_R(div_idx) = CN_INTEGER_THREE_IDX; 02572 IR_LINE_NUM_R(div_idx) = call_line_number; 02573 IR_COL_NUM_R(div_idx) = call_col_number; 02574 OPND_IDX(substring_len[i]) = div_idx; 02575 OPND_FLD(substring_len[i]) = IR_Tbl_Idx; 02576 } 02577 } 02578 else { 02579 ATD_TYPE_IDX(tmp_attr) = CG_INTEGER_DEFAULT_TYPE; 02580 } 02581 02582 COPY_COMMON_ATTR_INFO(OPND_IDX(dummy_opnd[i]), 02583 new_darg_attr, 02584 Data_Obj); 02585 02586 COPY_VARIANT_ATTR_INFO(OPND_IDX(dummy_opnd[i]), 02587 new_darg_attr, 02588 Data_Obj); 02589 02590 if ((OPND_IDX(flipped_opnd[i]) != NULL_IDX) && 02591 ATD_RESHAPE_ARRAY_OPT(OPND_IDX(flipped_opnd[i]))) { 02592 flipped_bd_idx = ATD_ARRAY_IDX(OPND_IDX(flipped_opnd[i])); 02593 dummy_bd_idx = ATD_ARRAY_IDX(OPND_IDX(dummy_opnd[i])); 02594 02595 if (BD_RANK(flipped_bd_idx) > BD_RANK(dummy_bd_idx)) { 02596 /* 02597 Move the bounds information from the actual 02598 argument to the new automatic array. 02599 The automatic array must inherit the 02600 bounds information from the actual argument 02601 because all dummy argument references within 02602 the inlined code will be re-written with more 02603 subscript expressions. 02604 */ 02605 ATD_ARRAY_IDX(new_darg_attr) = 02606 ATD_ARRAY_IDX(OPND_IDX(flipped_opnd[i])); 02607 ATD_RESHAPE_ARRAY_IDX(new_darg_attr) = 02608 ATD_RESHAPE_ARRAY_IDX(OPND_IDX(flipped_opnd[i])); 02609 02610 ATD_RESHAPE_ARRAY_OPT(new_darg_attr) = TRUE; 02611 02612 } 02613 else { 02614 /* 02615 Move the bounds information from the dummy 02616 argument to the new automatic array. 02617 */ 02618 ATD_RESHAPE_ARRAY_IDX(new_darg_attr) = 02619 ATD_RESHAPE_ARRAY_IDX(OPND_IDX(dummy_opnd[i])); 02620 } 02621 02622 if (ATD_RESHAPE_ARRAY_OPT(new_darg_attr)) { 02623 /* 02624 Attach an AL entry at the head of the list for 02625 the current scope. The attribute being attached 02626 is the new automatic array. 02627 */ 02628 NTR_ATTR_LIST_TBL(tmp_al_idx); 02629 AL_ATTR_IDX(tmp_al_idx) = new_darg_attr; 02630 al_idx = SCP_RESHAPE_ARRAY_LIST(curr_scp_idx); 02631 SCP_RESHAPE_ARRAY_LIST(curr_scp_idx) = tmp_al_idx; 02632 AL_NEXT_IDX(tmp_al_idx) = al_idx; 02633 } 02634 } 02635 02636 02637 loc_fld = IR_Tbl_Idx; 02638 NTR_IR_TBL(loc_idx); 02639 IR_OPR(loc_idx) = Aloc_Opr; 02640 IR_TYPE_IDX(loc_idx) = ATD_TYPE_IDX(tmp_attr); 02641 IR_LINE_NUM(loc_idx) = call_line_number; 02642 IR_COL_NUM(loc_idx) = call_col_number; 02643 02644 if (ATD_TYPE_IDX(tmp_attr) == CRI_Ch_Ptr_8) { 02645 IR_IDX_L(loc_idx) = OPND_IDX(substringing_tree[i]); 02646 IR_FLD_L(loc_idx) = OPND_FLD(substringing_tree[i]); 02647 02648 /* 02649 Clear the substring offsets here because they have 02650 already been absorbed into the pointer of the 02651 based array. 02652 */ 02653 for (k = 0; k <= MAX_INLINE_ARGS-1; k++) { 02654 OPND_IDX(substring_offset[k]) = CN_INTEGER_ZERO_IDX; 02655 OPND_FLD(substring_offset[k]) = CN_Tbl_Idx; 02656 } 02657 02658 if (TYP_CHAR_CLASS(ATD_TYPE_IDX(new_darg_attr)) == 02659 Assumed_Size_Char) { 02660 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 02661 TYP_TYPE(TYP_WORK_IDX) = Character; 02662 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 02663 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char; 02664 TYP_RESOLVED(TYP_WORK_IDX) = TRUE; 02665 type_idx = ntr_type_tbl(); 02666 ATD_TYPE_IDX(new_darg_attr) = type_idx; 02667 02668 TYP_FLD(ATD_TYPE_IDX(new_darg_attr)) = 02669 TYP_FLD(ATD_TYPE_IDX(OPND_IDX(actual_opnd[i]))); 02670 TYP_IDX(ATD_TYPE_IDX(new_darg_attr)) = 02671 TYP_IDX(ATD_TYPE_IDX(OPND_IDX(actual_opnd[i]))); 02672 TYP_CHAR_CLASS(ATD_TYPE_IDX(new_darg_attr)) = 02673 TYP_CHAR_CLASS(ATD_TYPE_IDX(OPND_IDX(actual_opnd[i]))); 02674 } 02675 } 02676 else { 02677 IR_IDX_L(loc_idx) = OPND_IDX(subscripting_tree[i]); 02678 IR_FLD_L(loc_idx) = OPND_FLD(subscripting_tree[i]); 02679 } 02680 02681 IR_LINE_NUM_L(loc_idx) = call_line_number; 02682 IR_COL_NUM_L(loc_idx) = call_col_number; 02683 02684 if (IR_OPR(OPND_IDX(subscripting_tree[i])) == 02685 Dv_Access_Base_Addr || 02686 call_by_value) { 02687 loc_idx = OPND_IDX(subscripting_tree[i]); 02688 loc_fld = OPND_FLD(subscripting_tree[i]); 02689 } 02690 02691 AT_ATTR_LINK(new_darg_attr) = NULL_IDX; 02692 AT_COMPILER_GEND(new_darg_attr) = TRUE; 02693 AT_DEFINED(new_darg_attr) = TRUE; 02694 AT_IS_DARG(new_darg_attr) = FALSE; 02695 ATD_CLASS(new_darg_attr) = Variable; 02696 ATD_AUTOMATIC(new_darg_attr) = TRUE; 02697 ATD_AUTO_BASE_IDX(new_darg_attr) = tmp_attr; 02698 CREATE_ID(stor_name, sb_name[Based_Blk], sb_len[Based_Blk]); 02699 based_blk = ntr_stor_blk_tbl(stor_name.string, 02700 sb_len[Based_Blk], 02701 call_line_number, 02702 call_col_number, 02703 Based); 02704 ATD_STOR_BLK_IDX(new_darg_attr) = based_blk; 02705 if (name_substitution) { 02706 /* intentionally blank */ 02707 } 02708 else { 02709 OPND_IDX(actual_opnd[i]) = new_darg_attr; 02710 OPND_FLD(actual_opnd[i]) = AT_Tbl_Idx; 02711 } 02712 02713 if (inlinable && !name_substitution) { 02714 NTR_IR_TBL(asg_idx); 02715 IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(tmp_attr); 02716 IR_OPR(asg_idx) = Asg_Opr; 02717 IR_LINE_NUM(asg_idx) = call_line_number; 02718 IR_COL_NUM(asg_idx) = call_col_number; 02719 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 02720 IR_IDX_L(asg_idx) = tmp_attr; 02721 IR_LINE_NUM_L(asg_idx) = call_line_number; 02722 IR_COL_NUM_L(asg_idx) = call_col_number; 02723 IR_FLD_R(asg_idx) = loc_fld; 02724 IR_IDX_R(asg_idx) = loc_idx; 02725 IR_LINE_NUM_R(asg_idx) = call_line_number; 02726 IR_COL_NUM_R(asg_idx) = call_col_number; 02727 02728 curr_stmt_sh_idx = copy_in_sh; 02729 gen_sh(Before, 02730 Assignment_Stmt, 02731 call_line_number, 02732 call_col_number, 02733 FALSE, 02734 FALSE, 02735 TRUE); 02736 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 02737 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 02738 } 02739 } 02740 02741 if (inlinable && 02742 dummy_modified && 02743 copy_out_array_element != NULL_IDX) { 02744 NTR_IR_TBL(asg_idx); 02745 IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(copy_out_array_element); 02746 IR_OPR(asg_idx) = Asg_Opr; 02747 IR_LINE_NUM(asg_idx) = call_line_number; 02748 IR_COL_NUM(asg_idx) = call_col_number; 02749 IR_FLD_L(asg_idx) = OPND_FLD(subscripting_tree[i]); 02750 copy_subtree(&(subscripting_tree[i]), &opnd); 02751 COPY_OPND(IR_OPND_L(asg_idx), opnd); 02752 new_idx = OPND_IDX(opnd); 02753 l = 1; 02754 list_idx = IR_IDX_R(new_idx); 02755 while (OPND_IDX(subscript_attr[l]) != NULL_IDX) { 02756 COPY_OPND(IL_OPND(list_idx), subscript_attr[l]); 02757 l = l + 1; 02758 list_idx = IL_NEXT_LIST_IDX(list_idx); 02759 } 02760 02761 IR_FLD_R(asg_idx) = AT_Tbl_Idx; 02762 IR_IDX_R(asg_idx) = copy_out_array_element; 02763 IR_LINE_NUM_L(asg_idx) = call_line_number; 02764 IR_COL_NUM_L(asg_idx) = call_col_number; 02765 IR_LINE_NUM_R(asg_idx) = call_line_number; 02766 IR_COL_NUM_R(asg_idx) = call_col_number; 02767 02768 curr_stmt_sh_idx = SH_NEXT_IDX(call_sh); 02769 gen_sh(Before, 02770 Assignment_Stmt, 02771 call_line_number, 02772 call_col_number, 02773 FALSE, 02774 FALSE, 02775 TRUE); 02776 02777 copy_out_sh[next_copy_out_sh_idx] = 02778 SH_PREV_IDX(curr_stmt_sh_idx); 02779 next_copy_out_sh_idx = next_copy_out_sh_idx + 1; 02780 02781 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 02782 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 02783 } 02784 02785 if (inlinable && 02786 dummy_modified && 02787 copy_out_DV_scalar != NULL_IDX) { 02788 NTR_IR_TBL(asg_idx); 02789 IR_TYPE_IDX(asg_idx) = ATD_TYPE_IDX(copy_out_DV_scalar); 02790 IR_OPR(asg_idx) = Asg_Opr; 02791 IR_LINE_NUM(asg_idx) = call_line_number; 02792 IR_COL_NUM(asg_idx) = call_col_number; 02793 IR_FLD_L(asg_idx) = OPND_FLD(subscripting_tree[i]); 02794 IR_IDX_L(asg_idx) = OPND_IDX(subscripting_tree[i]); 02795 IR_FLD_R(asg_idx) = AT_Tbl_Idx; 02796 IR_IDX_R(asg_idx) = copy_out_DV_scalar; 02797 IR_LINE_NUM_L(asg_idx) = call_line_number; 02798 IR_COL_NUM_L(asg_idx) = call_col_number; 02799 IR_LINE_NUM_R(asg_idx) = call_line_number; 02800 IR_COL_NUM_R(asg_idx) = call_col_number; 02801 02802 curr_stmt_sh_idx = SH_NEXT_IDX(call_sh); 02803 gen_sh(Before, 02804 Assignment_Stmt, 02805 call_line_number, 02806 call_col_number, 02807 FALSE, 02808 FALSE, 02809 TRUE); 02810 02811 copy_out_sh[next_copy_out_sh_idx] = 02812 SH_PREV_IDX(curr_stmt_sh_idx); 02813 next_copy_out_sh_idx = next_copy_out_sh_idx + 1; 02814 02815 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 02816 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 02817 } 02818 02819 /* 02820 This is so that scalar optimization sees the 02821 potential alias. 02822 */ 02823 if (inlinable && 02824 OPND_FLD(actual_opnd[i]) == AT_Tbl_Idx && 02825 AT_OBJ_CLASS(OPND_IDX(actual_opnd[i])) == Data_Obj && 02826 ATD_IM_A_DOPE(OPND_IDX(actual_opnd[i]))) { 02827 02828 tmp_sh = call_sh; 02829 while (tmp_sh != NULL_IDX) { 02830 if (IR_OPR(SH_IR_IDX(tmp_sh)) == Dv_Whole_Copy_Opr || 02831 IR_OPR(SH_IR_IDX(tmp_sh)) == Dv_Def_Asg_Opr) { 02832 attr_idx = find_left_attr(&IR_OPND_L(SH_IR_IDX(tmp_sh))); 02833 if (attr_idx == OPND_IDX(actual_opnd[i])) { 02834 02835 if (IR_OPR(SH_IR_IDX(tmp_sh)) == Dv_Def_Asg_Opr) { 02836 attr_idx = 02837 find_left_attr( 02838 &IL_OPND(IR_IDX_L(IR_IDX_R(SH_IR_IDX(tmp_sh))))); 02839 } 02840 else { 02841 attr_idx = 02842 find_left_attr(&IR_OPND_R(SH_IR_IDX(tmp_sh))); 02843 } 02844 02845 tmp_attr = NULL_IDX; 02846 if (IR_FLD_R(SH_IR_IDX(tmp_sh)) == IR_Tbl_Idx && 02847 IR_OPR(IR_IDX_R(SH_IR_IDX(tmp_sh)))==Struct_Opr) { 02848 tmp_attr = 02849 find_base_attr(&IR_OPND_R(SH_IR_IDX(tmp_sh)), 02850 &line, 02851 &col); 02852 } 02853 02854 if (attr_idx != NULL_IDX && 02855 attr_idx != OPND_IDX(actual_opnd[i])) { 02856 NTR_ATTR_LIST_TBL(list_idx1); 02857 AL_ATTR_IDX(list_idx1) = attr_idx; 02858 ATD_DV_ALIAS(OPND_IDX(actual_opnd[i])) = list_idx1; 02859 02860 if (tmp_attr != NULL_IDX) { 02861 NTR_ATTR_LIST_TBL(list_idx2); 02862 AL_ATTR_IDX(list_idx2) = tmp_attr; 02863 AL_NEXT_IDX(list_idx1) = list_idx2; 02864 } 02865 } 02866 break; 02867 } 02868 } 02869 tmp_sh = SH_PREV_IDX(tmp_sh); 02870 } 02871 } 02872 02873 if (OPND_FLD(actual_opnd[i]) == AT_Tbl_Idx && 02874 struct_base_attr_idx != NULL_IDX && 02875 TYP_TYPE(ATD_TYPE_IDX(OPND_IDX(actual_opnd[i]))) == 02876 Structure) { 02877 OPND_IDX(actual_opnd[i]) = struct_base_attr_idx; 02878 OPND_FLD(actual_opnd[i]) = AT_Tbl_Idx; 02879 } 02880 02881 check_actual_and_dummy(actual_opnd[i], dummy_opnd[i], i); 02882 02883 actual_arg_list_idx = IL_NEXT_LIST_IDX(actual_arg_list_idx); 02884 i = i + 1; 02885 j = j + 1; 02886 struct_base_attr_idx = NULL_IDX; 02887 } 02888 02889 /* 02890 Make a copy of the routine to be linked in place of the call. 02891 */ 02892 sh_count = 0; 02893 processing_ENTRY_called = FALSE; 02894 if (inlinable) { 02895 entry_label_attr_idx = gen_internal_lbl(call_line_number); 02896 exit_label_attr_idx = gen_internal_lbl(call_line_number); 02897 make_copy_of_routine(ATP_FIRST_SH_IDX(pgm_attr_idx)); 02898 } 02899 02900 /* 02901 This routine had more than 350 statement headers in 02902 the IR which represents that routine. This is the 02903 threshold used to determine that the routine contains 02904 too much text to be inlined. Stop inlining. If the 02905 user has specified an INLINEALWAYS directive on this 02906 routine, then ignore this limit. 02907 */ 02908 if (!ATP_INLINE_ALWAYS(pgm_attr_idx)) { 02909 if (sh_count > 350) { 02910 inlinable = FALSE; 02911 PRINTMSG(call_line_number, 02912 1347, 02913 Inline, 02914 call_col_number, 02915 AT_OBJ_NAME_PTR(pgm_attr_idx)); 02916 } 02917 } 02918 02919 02920 /* 02921 This check here is a saftey valve. Table sizes 02922 are checked here. If we are approaching dangerous limits, 02923 we just stop inlining. The values are arbitrary. 02924 */ 02925 if (npi > (MAX_INLINED_ROUTINES - 5) || table_overflow) { 02926 inlinable = FALSE; 02927 PRINTMSG(call_line_number, 02928 1202, 02929 Inline, 02930 call_col_number, 02931 AT_OBJ_NAME_PTR(pgm_attr_idx), 02932 "internal table(s) almost full"); 02933 } 02934 02935 02936 /* 02937 Link the IR of the routine in place of the call. 02938 NOTE: There may have been reasons that a routine can 02939 not be inlined that were encountered while trying to 02940 make the copy of that routine. If so, inlinable will 02941 have been set to FALSE. 02942 */ 02943 if (inlinable) { 02944 NTR_IR_TBL(asg_idx); 02945 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 02946 IR_OPR(asg_idx) = Br_Uncond_Opr; 02947 IR_LINE_NUM(asg_idx) = call_line_number; 02948 IR_COL_NUM(asg_idx) = call_col_number; 02949 IR_OPND_L(asg_idx) = null_opnd; 02950 IR_FLD_R(asg_idx) = AT_Tbl_Idx; 02951 IR_IDX_R(asg_idx) = entry_label_attr_idx; 02952 IR_LINE_NUM_R(asg_idx) = call_line_number; 02953 IR_COL_NUM_R(asg_idx) = call_col_number; 02954 curr_stmt_sh_idx = call_sh; 02955 gen_sh(Before, 02956 Goto_Stmt, 02957 call_line_number, 02958 call_col_number, 02959 FALSE, 02960 FALSE, 02961 TRUE); 02962 SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx; 02963 SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE; 02964 02965 02966 NTR_IR_TBL(asg_idx); 02967 IR_TYPE_IDX(asg_idx) = TYPELESS_DEFAULT_TYPE; 02968 IR_OPR(asg_idx) = Label_Opr; 02969 IR_LINE_NUM(asg_idx) = call_line_number; 02970 IR_COL_NUM(asg_idx) = call_col_number; 02971 IR_FLD_L(asg_idx) = AT_Tbl_Idx; 02972 IR_IDX_L(asg_idx) = exit_label_attr_idx; 02973 IR_OPND_R(asg_idx) = null_opnd; 02974 IR_LINE_NUM_L(asg_idx) = call_line_number; 02975 IR_COL_NUM_L(asg_idx) = call_col_number; 02976 curr_stmt_sh_idx = call_sh; 02977 gen_sh(After, 02978 Continue_Stmt, 02979 call_line_number, 02980 call_col_number, 02981 FALSE, 02982 TRUE, 02983 TRUE); 02984 SH_IR_IDX(curr_stmt_sh_idx) = asg_idx; 02985 SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE; 02986 02987 curr_stmt_sh_idx = call_sh; 02988 insert_sh_chain_before(copy_head); 02989 02990 something_was_inlined = TRUE; 02991 SH_IR_IDX(call_sh) = Null_Opr; 02992 02993 next_pgm_idx[npi] = pgm_attr_idx; 02994 npi = npi + 1; 02995 02996 PRINTMSG(call_line_number, 02997 1204, 02998 Inline, 02999 call_col_number, 03000 AT_OBJ_NAME_PTR(pgm_attr_idx)); 03001 } 03002 else { 03003 /* 03004 During the creation of the copy of the routine 03005 something was encountered that has made it 03006 impossible to inline this particular call site. 03007 As a result, we must clear any of the copy out 03008 text that was created at argument setup time. 03009 */ 03010 for (i = 0; i <= MAX_INLINE_ARGS-1; i++) { 03011 if (copy_out_sh[i] != NULL_IDX) { 03012 SH_IR_IDX(copy_out_sh[i]) = Null_Opr; 03013 } 03014 } 03015 } 03016 } 03017 break; 03018 03019 default : 03020 function_call = TRUE; 03021 srch_for_calls(IR_IDX_L(ir_idx), IR_FLD_L(ir_idx)); 03022 function_call = FALSE; 03023 03024 function_call = TRUE; 03025 srch_for_calls(IR_IDX_R(ir_idx), IR_FLD_R(ir_idx)); 03026 function_call = FALSE; 03027 break; 03028 } 03029 break; 03030 03031 default : 03032 break; 03033 } 03034 03035 TRACE (Func_Exit, "srch_for_calls", NULL); 03036 03037 return; 03038 03039 } /* srch_for_calls */ 03040 03041 03042 03043 03044 03045 /******************************************************************************\ 03046 |* *| 03047 |* Description: *| 03048 |* This is the main driver for inline processing. This routine *| 03049 |* traverses the statement headers for the current routine being *| 03050 |* compiled. *| 03051 |* *| 03052 |* Input parameters: *| 03053 |* NONE *| 03054 |* *| 03055 |* Output parameters: *| 03056 |* NONE *| 03057 |* *| 03058 |* Returns: *| 03059 |* NOTHING *| 03060 |* *| 03061 \******************************************************************************/ 03062 void inline_processing(int first_sh_idx) 03063 03064 { 03065 int sh; 03066 int i; 03067 int save_curr_stmt_sh_idx; 03068 int save_curr_scp_idx; 03069 int ncs = 0; 03070 int child_scopes[MAX_INLINED_ROUTINES]; 03071 03072 03073 TRACE (Func_Entry, "inline_processing", NULL); 03074 03075 for (i = 0; i <= MAX_INLINED_ROUTINES-1; i++) { 03076 child_scopes[i] = NULL_IDX; 03077 } 03078 save_curr_stmt_sh_idx = curr_stmt_sh_idx; 03079 save_curr_scp_idx = curr_scp_idx; 03080 03081 PROCESS_CHILD: 03082 03083 PROCESS_SIBLING: 03084 03085 table_overflow = FALSE; 03086 03087 npi = 0; 03088 for (i = 0; i <= MAX_INLINED_ROUTINES-1; i++) { 03089 next_pgm_idx[i] = NULL_IDX; 03090 } 03091 03092 ANOTHER_PASS: 03093 03094 inline_in_effect = FALSE; 03095 noinline_in_effect = FALSE; 03096 something_was_inlined = FALSE; 03097 loop_nest = 0; 03098 parallel_region = 0; 03099 03100 sh = first_sh_idx; 03101 03102 while (sh != NULL_IDX) { 03103 if (SH_IR_IDX(sh) != NULL_IDX) { 03104 if (IR_OPR(SH_IR_IDX(sh)) == Loop_Info_Opr) { 03105 loop_nest = loop_nest + 1; 03106 } 03107 else if (SH_PARENT_BLK_IDX(sh) != NULL_IDX && 03108 SH_STMT_TYPE(sh) == Continue_Stmt && 03109 IR_OPR(SH_IR_IDX(SH_PARENT_BLK_IDX(sh))) == Loop_Info_Opr) { 03110 loop_nest = loop_nest - 1; 03111 } 03112 03113 if (IR_OPR(SH_IR_IDX(sh)) == Doall_Cmic_Opr) { 03114 parallel_region = parallel_region + 1; 03115 } 03116 03117 if (SH_DOALL_LOOP_END(sh)) { 03118 parallel_region = parallel_region - 1; 03119 } 03120 03121 call_sh = sh; 03122 srch_for_calls(SH_IR_IDX(sh), IR_Tbl_Idx); 03123 } 03124 03125 sh = SH_NEXT_IDX(sh); 03126 } 03127 03128 if (something_was_inlined) { 03129 goto ANOTHER_PASS; 03130 } 03131 03132 03133 /* 03134 Check to see if there is a child scope of this current scope. 03135 If so, save it away to be processed later. 03136 */ 03137 if (SCP_FIRST_CHILD_IDX(curr_scp_idx) != NULL_IDX) { 03138 ncs = ncs + 1; 03139 if (ncs >= MAX_INLINED_ROUTINES) { 03140 PRINTMSG(call_line_number, 03141 1315, 03142 Internal, 03143 call_col_number); 03144 } 03145 child_scopes[ncs] = SCP_FIRST_CHILD_IDX(curr_scp_idx); 03146 } 03147 03148 /* 03149 Process the next sibling scope of the current scope being 03150 processed. 03151 */ 03152 if (SCP_SIBLING_IDX(curr_scp_idx) != NULL_IDX) { 03153 curr_scp_idx = SCP_SIBLING_IDX(curr_scp_idx); 03154 first_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx); 03155 goto PROCESS_SIBLING; 03156 } 03157 03158 /* 03159 Process any child scope which was saved away. 03160 */ 03161 for (i = 1; i <= MAX_INLINED_ROUTINES-1; i++) { 03162 if (child_scopes[i] != NULL_IDX) { 03163 curr_scp_idx = child_scopes[i]; 03164 first_sh_idx = SCP_FIRST_SH_IDX(curr_scp_idx); 03165 child_scopes[i] = NULL_IDX; 03166 goto PROCESS_CHILD; 03167 } 03168 } 03169 03170 curr_stmt_sh_idx = save_curr_stmt_sh_idx; 03171 curr_scp_idx = save_curr_scp_idx; 03172 03173 TRACE (Func_Exit, "inline_processing", NULL); 03174 03175 return; 03176 03177 } /* inline_processing */ 03178 03179
1.7.6.1 
