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 * ==================================================================== 00038 * 00039 * 00040 * Revision history: 00041 * dd-mmm-95 - Original Version 00042 * 00043 * Description: contains routines to convert address operations. 00044 * Entry points from PDGCS layer are 00045 * fei_seq_subscr 00046 * fei_subscr_triplet 00047 * fei_subscr_size 00048 * fei_substr 00049 * fei_as_ref 00050 * fei_field_dot 00051 * fei_addr 00052 * fei_fcd 00053 * 00054 * general routines to address,store or load STs & WNs 00055 * are here. 00056 * 00057 * ==================================================================== 00058 * ==================================================================== 00059 */ 00060 00061 static char *source_file = __FILE__; 00062 00063 /* sgi includes */ 00064 00065 #include "defs.h" 00066 #include "glob.h" 00067 #include "stab.h" 00068 #include "strtab.h" 00069 #include "errors.h" 00070 #include "config_targ.h" 00071 #include "config_debug.h" 00072 #include "wn.h" 00073 #include "wn_util.h" 00074 #include "wn_trap.h" 00075 #include "f90_utils.h" 00076 #include "pu_info.h" 00077 00078 /* Cray includes */ 00079 00080 #include "i_cvrt.h" 00081 00082 /* conversion includes */ 00083 00084 #include "cwh_defines.h" 00085 #include "cwh_stk.h" 00086 #include "cwh_preg.h" 00087 #include "cwh_stab.h" 00088 #include "cwh_auxst.h" 00089 #include "cwh_block.h" 00090 #include "cwh_types.h" 00091 #include "cwh_stmt.h" 00092 #include "cwh_stab.h" 00093 #include "cwh_expr.h" 00094 #include "cwh_io.h" 00095 #include "cwh_intrin.h" 00096 #include "cwh_dst.h" 00097 #include "sgi_cmd_line.h" 00098 #include "cwh_addr.h" 00099 #include "cwh_addr.i" 00100 00101 /*=============================================== 00102 * 00103 * fei_seq_subscr 00104 * 00105 * Handles a single subscript in a reference to 00106 * a sequential array (cf. fei_nseq_subscr), hence 00107 * the stride multiplier is ignored - if there is 00108 * a stride then it has already been folded into 00109 * the subscript triplet (and the stride multiplier 00110 * would be one..). 00111 * 00112 * The stack has stride mult, extent, lower bound, 00113 * subscript. The subscript may be a scalar, or an 00114 * array value (OPC_TRIPLET). Below the subscript 00115 * is the address expression - an ST or OPC_ARRAY 00116 * or OPC_ARRSECTION. If the address is an ST or 00117 * OPC_ARRAY, it may be a section subscript hasn't 00118 * been seen yet, so if one appears, make an OPC_ARRSECTION. 00119 * 00120 * Pop lb,extent, (ignore stride mult) & subscript 00121 * & look at the address TOS. Possibilities : 00122 * 00123 * TOS is ST - make OPC_ARRAY, or if subscript 00124 * array valued an OPC_ARRSECTION. 00125 * 00126 * TOS is WN - may be OPC_ARRAY (convert to OPC_ARRSECTION 00127 * if array-valued subscript) or OPC_ARRSECTION 00128 * 00129 * TOS is FLD - add the offset to an OPC_ARRAY or 00130 * OPC_ARRSECTION. 00131 * 00132 * subscript is OPC_TRIPLET, or ST or WN - tack it in 00133 * to the address OPC_ARRAY/ARRSECTION. 00134 * 00135 * subscript is OPC_ARRSECTION - vv valued subscript 00136 * tack on an OPC_ARRAYEXP and LDID to 00137 * subscript & add to the address 00138 * OPC_ARRAY/ARRSECTION. 00139 * 00140 * Make the bound zero-based. 00141 * 00142 *=============================================== 00143 */ 00144 00145 extern void 00146 fei_seq_subscr( TYPE result_type ,INT32 kidsnum) 00147 { 00148 WN *ex ; 00149 WN *lb ; 00150 WN *sb ; 00151 WN *ar ; 00152 WN *ad ; 00153 WN *wt ; 00154 WN *top_wn; 00155 ST *st ; 00156 TY_IDX ty ; 00157 00158 BOOL array_val ; 00159 BOOL sect ; 00160 BOOL trip ; 00161 TY_IDX ta ; 00162 00163 OPCODE op ; 00164 FLD_det det ; 00165 WN * bounds_assertion; 00166 char *field_name,*array_name; 00167 00168 (void) cwh_stk_pop_whatever(); /* stride mult*/ 00169 ex = cwh_expr_operand(NULL) ; 00170 lb = cwh_expr_operand(NULL) ; 00171 sb = cwh_expr_operand(NULL) ; 00172 bounds_assertion = cwh_addr_do_bounds_check(sb, lb, ex); 00173 00174 trip = cwh_addr_is_triplet(sb); 00175 sb = F90_Wrap_ARREXP(sb); 00176 sect = WNOPR(sb) == OPR_ARRAYEXP; 00177 00178 array_val = sect || trip ; 00179 op = array_val ? opc_section : opc_array ; 00180 00181 switch(cwh_stk_get_class()) { 00182 00183 case ADDR_item: 00184 ta = cwh_stk_get_TY(); 00185 ar = cwh_expr_address(f_NONE); 00186 /* ar had better be an ARRAY or ARRSECTION node */ 00187 if (array_val) 00188 if (cwh_addr_is_array(ar)) 00189 WN_set_opcode(ar, opc_section) ; 00190 00191 cwh_addr_insert_bounds_check(bounds_assertion,ar); 00192 ar = cwh_addr_add_bound(ar,ex,sb); 00193 cwh_stk_push_typed(ar,WN_item,ta); 00194 break ; 00195 00196 case WN_item: 00197 ta = cwh_stk_get_TY(); 00198 top_wn = cwh_stk_pop_WN(); 00199 cwh_stk_push_typed(top_wn,WN_item,ta); 00200 ar = cwh_expr_address(f_NONE); 00201 /* ar had better be an ARRAY or ARRSECTION node */ 00202 if (array_val) 00203 if (cwh_addr_is_array(ar)) 00204 WN_set_opcode(ar, opc_section) ; 00205 00206 if (WN_operator(top_wn)==OPR_STRCTFLD || 00207 WN_operator(top_wn)==OPR_ILOAD && 00208 WN_operator(WN_kid0(top_wn))==OPR_STRCTFLD ) 00209 ar = cwh_addr_array1(op,ar,ta,kidsnum); 00210 00211 cwh_addr_insert_bounds_check(bounds_assertion,ar); 00212 ar = cwh_addr_add_bound(ar,ex,sb); 00213 cwh_stk_push_typed(ar,WN_item,ta); 00214 break ; 00215 00216 case WN_item_whole_array: 00217 ta = cwh_stk_get_TY(); /* TRAP HERE dlai DLAI */ 00218 ar = cwh_expr_address(f_NONE); 00219 if (array_val) 00220 if (cwh_addr_is_array(ar)) 00221 WN_set_opcode(ar, opc_section) ; 00222 00223 cwh_addr_insert_bounds_check(bounds_assertion,ar); 00224 ar = cwh_addr_add_bound(ar,ex,sb); 00225 cwh_stk_push_typed(ar,WN_item_whole_array,ta); 00226 break ; 00227 00228 case ST_item: 00229 st = cwh_stk_pop_ST(); 00230 ty = ST_type(st); 00231 ad = cwh_addr_address_ST(st) ; 00232 ar = cwh_addr_array1(op,ad,ty,kidsnum); 00233 SET_ARRAY_NAME_MAP(ar,ST_name(st)); 00234 cwh_addr_insert_bounds_check(bounds_assertion,ar); 00235 ar = cwh_addr_add_bound(ar,ex,sb); 00236 cwh_stk_push(ar,WN_item); 00237 break ; 00238 00239 case DEREF_item: 00240 ty = cwh_stk_get_TY(); 00241 ad = cwh_expr_address(f_NONE); 00242 ar = cwh_addr_array1(op,ad,ty,kidsnum); 00243 cwh_addr_insert_bounds_check(bounds_assertion,ar); 00244 ar = cwh_addr_add_bound(ar,ex,sb); 00245 cwh_stk_push(ar,WN_item); 00246 break ; 00247 00248 00249 case ST_item_whole_array: 00250 st = cwh_stk_pop_ST(); 00251 ty = ST_type(st); 00252 ad = cwh_addr_address_ST(st) ; 00253 ar = cwh_addr_array1(op,ad,ty,kidsnum); 00254 SET_ARRAY_NAME_MAP(ar,ST_name(st)); 00255 cwh_addr_insert_bounds_check(bounds_assertion,ar); 00256 ar = cwh_addr_add_bound(ar,ex,sb); 00257 cwh_stk_push(ar,WN_item_whole_array); 00258 break ; 00259 00260 case FLD_item: 00261 field_name = cwh_stk_fld_name(); 00262 det = cwh_addr_offset() ; 00263 00264 /* Preserve TY info for the FLD */ 00265 /* (OPC_ARRAY doesn't hold a type */ 00266 /* a type and the fundemental address */ 00267 /* TY is that of a parent object ) */ 00268 00269 if (cwh_stk_get_class() == ST_item || 00270 cwh_stk_get_class() == ST_item_whole_array) { 00271 00272 st = cwh_stk_pop_ST(); 00273 ad = cwh_addr_address_ST(st,det.off,det.type); 00274 array_name = ST_name(st); 00275 00276 } else { 00277 00278 /* is array of array of derived type */ 00279 /* or similar. */ 00280 00281 ad = cwh_expr_address(f_NONE); 00282 array_name = GET_ARRAY_NAME_MAP(ad); 00283 wt = WN_CreateIntconst(opc_pint,det.off); 00284 ad = cwh_expr_bincalc(OPR_ADD,ad,wt); 00285 00286 } 00287 00288 ar = cwh_addr_array1(op,ad,det.type,kidsnum) ; 00289 if (strlen(field_name) > 0) { 00290 00291 if (array_name) { 00292 array_name = Index_To_Str(Save_Str2(array_name,field_name)); 00293 } else { 00294 array_name = Index_To_Str(Save_Str2("(unknown)",field_name)); 00295 } 00296 free(field_name); 00297 SET_ARRAY_NAME_MAP(ar,array_name); 00298 } 00299 cwh_addr_insert_bounds_check(bounds_assertion,ar); 00300 ar = cwh_addr_add_bound(ar,ex,sb); 00301 cwh_stk_push_typed(ar,WN_item,det.type); 00302 break ; 00303 00304 default: 00305 DevAssert((0),(" odd item in subscr")); 00306 } 00307 } 00308 00309 /*=============================================== 00310 * 00311 * cwh_addr_compute_stride_fudge_factor 00312 * 00313 * This routine takes a TY and computes whether 00314 * the stride multiplier is in words or bytes. 00315 * It returns 4 if it's in words, 1 if in bytes. 00316 * 00317 * ifndef NONCONTIG_BY_DIVIDE version 00318 *=============================================== 00319 */ 00320 static INT64 00321 cwh_addr_compute_stride_fudge_factor(TY_IDX in) 00322 { 00323 00324 TY_IDX ty_idx = cwh_types_array_TY(in); 00325 TY& t = Ty_Table[ty_idx]; 00326 DevAssert((TY_kind(t)==KIND_ARRAY),("can't get fudge factor for non-array type")); 00327 TY& ty = Ty_Table[TY_etype(t)]; 00328 00329 #define RETURN4 return(-4) 00330 #define RETURN2 return(-2) 00331 #define RETURN1 return(-1) 00332 00333 switch (TY_kind(ty)) { 00334 case KIND_SCALAR: 00335 /* Should be in words */ 00336 if (TY_size(ty) >= 4) { 00337 RETURN4; 00338 } else if (TY_size(ty) == 2) { 00339 RETURN2; 00340 } else { 00341 RETURN1; 00342 } 00343 00344 case KIND_ARRAY: 00345 RETURN1; 00346 00347 case KIND_STRUCT: 00348 if (TY_is_packed(ty)) { 00349 RETURN1; 00350 } else { 00351 RETURN4; 00352 } 00353 00354 default: 00355 DevAssert((0),("Don't know how to deal with this ty")); 00356 } 00357 RETURN4; 00358 } 00359 00360 00361 /* ================================================================ 00362 00363 Notes about non-contiguous array lowering 00364 00365 A noncontiguous array (an F90 pointer or assumed-shape dummy) 00366 is passed by a dope vector containing 00367 00368 1) a base address 00369 2) lower bounds for each dimension 00370 3) stride multipliers for each dimension 00371 00372 The unfortunate consequence of this is that the indexing methodology of the ARRAY 00373 node no longer works. Also unfortunately, the stride multipliers are in words 00374 (or sometimes bytes), not elements. So, the actual address expression for an array element 00375 A(I1...In) is 00376 00377 base + element_size*(SUM(i=1,n) (Ii-lbound(i))*(stride_mult(i)/fudge)) 00378 00379 So, we build: 00380 00381 ARRAY (-4 or -1) 00382 base address 00383 stride_mult_n 00384 . 00385 . 00386 . 00387 stride_mult_1 00388 (In - lbound n) 00389 . 00390 . 00391 . 00392 (I1 - lbound 1) 00393 00394 The negative element size indicates that the extents are actually stride multipliers. 00395 00396 Ugly, but it works. 00397 00398 ================================================================*/ 00399 00400 static void cwh_addr_fixup_nseq(WN **ex, WN **sb, WN *sm) 00401 { 00402 00403 /* This is a helper routine which alters the subscript and extent 00404 * for the cases in which we need to fold in the stride_multiplier. 00405 */ 00406 if (!may_be_noncontig) return; 00407 00408 WN_DELETE_Tree(*ex); 00409 *ex = sm; 00410 return; 00411 } 00412 00413 /*=============================================== 00414 * 00415 * fei_nseq_subscr 00416 * 00417 * Non-contiguous section subscript. This is 00418 * similar to fei_seq_subscr, but the stride 00419 * multiplier is used to compute the stride. 00420 * 00421 * The stack has stride mult extent,lb,subscript, 00422 * address. The address is a pointer though, so 00423 * it's converted into an OPC_ARRSECTION or OPC_ARRAY 00424 * 00425 * See notes above on non-contiguous sections. 00426 * and the description of the stack in in fei_seq_subscr. 00427 * 00428 *=============================================== 00429 */ 00430 extern void 00431 fei_nseq_subscr( TYPE result_type ) 00432 { 00433 WN *ex ; 00434 WN *lb ; 00435 WN *sb ; 00436 WN *sm ; 00437 WN *ar ; 00438 WN *ad ; 00439 WN *wt ; 00440 ST *st ; 00441 TY_IDX ty ; 00442 TY_IDX dope_ty ; 00443 WN_ESIZE esize; 00444 00445 TY_IDX ta ; 00446 BOOL array_val ; 00447 BOOL sect ; 00448 BOOL trip ; 00449 00450 OPCODE op ; 00451 FLD_det det ; 00452 WN * bounds_assertion; 00453 char *field_name,*array_name; 00454 00455 sm = cwh_expr_operand(NULL) ; /* stride mult*/ 00456 ex = cwh_expr_operand(NULL) ; 00457 lb = cwh_expr_operand(NULL) ; 00458 sb = cwh_expr_operand(NULL) ; 00459 bounds_assertion = cwh_addr_do_bounds_check(sb, lb, ex); 00460 00461 trip = cwh_addr_is_triplet(sb); 00462 sb = cwh_addr_zero_based(sb,lb); 00463 sb = F90_Wrap_ARREXP(sb); 00464 sect = WNOPR(sb) == OPR_ARRAYEXP; 00465 00466 array_val = sect || trip ; 00467 op = array_val ? opc_section : opc_array ; 00468 00469 switch(cwh_stk_get_class()) { 00470 case ADDR_item: 00471 case WN_item: 00472 case WN_item_whole_array: 00473 ta = cwh_stk_get_TY(); 00474 ar = cwh_expr_address(f_NONE); 00475 if (array_val) 00476 if (cwh_addr_is_array(ar)) 00477 WN_set_opcode(ar, opc_section) ; 00478 00479 if (WNOPR(ar)==OPR_ARRSECTION || WNOPR(ar)==OPR_ARRAY) { 00480 may_be_noncontig = (WN_element_size(ar) < 0 ); 00481 } 00482 cwh_addr_fixup_nseq(&ex,&sb,sm); 00483 cwh_addr_insert_bounds_check(bounds_assertion,ar); 00484 ar = cwh_addr_add_bound(ar,ex,sb); 00485 cwh_stk_push_typed(ar,WN_item,ta); 00486 break ; 00487 00488 case DEREF_item: 00489 may_be_noncontig = FALSE; 00490 dope_ty = cwh_stk_get_TY(); 00491 if (dope_ty) { 00492 TY& t = Ty_Table[dope_ty]; 00493 ty = FLD_type(TY_fld(t)); 00494 may_be_noncontig = TY_is_f90_pointer(t); 00495 } 00496 ar = cwh_expr_address(f_NONE); 00497 st = cwh_addr_WN_ST(ar); 00498 if (!dope_ty) { 00499 ty = ST_type(st); 00500 ty = cwh_types_dope_basic_TY(ty); 00501 } 00502 00503 if (ST_sclass(st) == SCLASS_FORMAL || 00504 ST_auxst_is_non_contiguous(st) || 00505 may_be_noncontig) { 00506 may_be_noncontig = TRUE; 00507 esize = cwh_addr_compute_stride_fudge_factor(ty); 00508 } 00509 array_name = GET_ARRAY_NAME_MAP(ar); 00510 ar = cwh_addr_array(op,ar,ty); 00511 if (array_name) { 00512 SET_ARRAY_NAME_MAP(ar,Index_To_Str(Save_Str2(ST_name(st),array_name))); 00513 } else { 00514 SET_ARRAY_NAME_MAP(ar,ST_name(st)); 00515 } 00516 if (may_be_noncontig) WN_element_size(ar) = esize; 00517 00518 if (array_val) 00519 if (cwh_addr_is_array(ar)) 00520 WN_set_opcode(ar, opc_section) ; 00521 00522 cwh_addr_fixup_nseq(&ex,&sb,sm); 00523 cwh_addr_insert_bounds_check(bounds_assertion,ar); 00524 ar = cwh_addr_add_bound(ar,ex,sb); 00525 cwh_stk_push(ar,WN_item); 00526 break; 00527 00528 case ST_item: 00529 case ST_item_whole_array: 00530 may_be_noncontig = FALSE; 00531 st = cwh_stk_pop_ST(); 00532 ty = ST_type(st); 00533 00534 if (ST_sclass(st) == SCLASS_FORMAL || 00535 ST_auxst_is_non_contiguous(st) || 00536 TY_is_f90_pointer(Ty_Table[ty])) { 00537 00538 may_be_noncontig = TRUE; 00539 esize = cwh_addr_compute_stride_fudge_factor(ty); 00540 } 00541 ad = cwh_addr_address_ST(st) ; 00542 ar = cwh_addr_array(op,ad,ty); 00543 SET_ARRAY_NAME_MAP(ar,ST_name(st)); 00544 if (may_be_noncontig) WN_element_size(ar) = esize; 00545 00546 cwh_addr_fixup_nseq(&ex,&sb,sm); 00547 cwh_addr_insert_bounds_check(bounds_assertion,ar); 00548 ar = cwh_addr_add_bound(ar,ex,sb); 00549 cwh_stk_push(ar,WN_item); 00550 break ; 00551 00552 case FLD_item: 00553 may_be_noncontig = FALSE; 00554 field_name = cwh_stk_fld_name(); 00555 det = cwh_addr_offset() ; 00556 00557 if (TY_is_f90_pointer(Ty_Table[det.type])) { 00558 ty = det.type; /* eraxxon: added to initialize 'ty' */ 00559 may_be_noncontig = TRUE; 00560 esize = cwh_addr_compute_stride_fudge_factor(ty); 00561 } 00562 00563 /* Preserve TY info for the FLD */ 00564 /* (OPC_ARRAY doesn't hold a type */ 00565 /* a type and the fundemental address */ 00566 /* TY is that of a parent object ) */ 00567 00568 if (cwh_stk_get_class() == ST_item || cwh_stk_get_class() == ST_item_whole_array) { 00569 st = cwh_stk_pop_ST(); 00570 ad = cwh_addr_address_ST(st,det.off,det.type) ; 00571 array_name = ST_name(st); 00572 00573 } else { 00574 00575 /* is array of array of derived type */ 00576 /* or similar. */ 00577 00578 ad = cwh_expr_address(f_NONE); 00579 array_name = GET_ARRAY_NAME_MAP(ad); 00580 wt = WN_CreateIntconst(opc_pint,det.off); 00581 ad = cwh_expr_bincalc(OPR_ADD,ad,wt); 00582 } 00583 00584 ar = cwh_addr_array(op,ad,det.type) ; 00585 if (strlen(field_name) > 0) { 00586 00587 if (array_name) { 00588 array_name = Index_To_Str(Save_Str2(array_name,field_name)); 00589 } else { 00590 array_name = Index_To_Str(Save_Str2("(unknown)",field_name)); 00591 } 00592 free(field_name); 00593 SET_ARRAY_NAME_MAP(ar,array_name); 00594 } 00595 00596 if (may_be_noncontig) WN_element_size(ar) = esize; 00597 cwh_addr_fixup_nseq(&ex,&sb,sm); 00598 cwh_addr_insert_bounds_check(bounds_assertion,ar); 00599 ar = cwh_addr_add_bound(ar,ex,sb); 00600 cwh_stk_push_typed(ar,WN_item,det.type); 00601 break ; 00602 00603 default: 00604 DevAssert((0),(" odd item in subscr")); 00605 } 00606 } 00607 00608 /*=============================================== 00609 * 00610 * fei_subscr_triplet 00611 * 00612 * A subscript triplet will have lb,ub,str on 00613 * the stack with the subscripted item beneath. 00614 * The expressions are as written in the source, 00615 * so make a zero-based OPC_TRIPLET, & push it. 00616 * 00617 *=============================================== 00618 */ 00619 extern void 00620 fei_subscr_triplet(TYPE result_type ) 00621 { 00622 WN *lb ; 00623 WN *ub ; 00624 WN *str ; 00625 WN *wt ; 00626 WN *wn; 00627 00628 if (cwh_stk_get_class() == WN_item) { 00629 wn = cwh_stk_pop_WN(); 00630 00631 if (wn == NULL) 00632 str = wn; 00633 else 00634 if ( WNOPR(wn)== OPR_IMPLICIT_BND) 00635 str = wn; 00636 else { 00637 cwh_stk_push(wn,WN_item); 00638 str = cwh_expr_operand(NULL) ; 00639 } 00640 }else 00641 str = cwh_expr_operand(NULL) ; 00642 00643 if (cwh_stk_get_class() == WN_item) { 00644 wn = cwh_stk_pop_WN(); 00645 if (wn == NULL) 00646 ub = wn; 00647 else 00648 if (WNOPR(wn)== OPR_IMPLICIT_BND) 00649 ub = wn; 00650 else { 00651 cwh_stk_push(wn,WN_item); 00652 ub = cwh_expr_operand(NULL) ; 00653 } 00654 }else 00655 ub = cwh_expr_operand(NULL) ; 00656 00657 if (cwh_stk_get_class() == WN_item) { 00658 wn = cwh_stk_pop_WN(); 00659 if (wn == NULL) 00660 lb = wn; 00661 else 00662 if (WNOPR(wn)== OPR_IMPLICIT_BND) 00663 lb = wn; 00664 else { 00665 cwh_stk_push(wn,WN_item); 00666 lb = cwh_expr_operand(NULL) ; 00667 } 00668 }else 00669 lb = cwh_expr_operand(NULL) ; 00670 00671 wt = cwh_addr_triplet(lb,ub,str); 00672 00673 cwh_stk_push(wt,WN_item); 00674 } 00675 00676 /*=============================================== 00677 * 00678 * fei_subscr_src_triplet 00679 * 00680 * A subscript triplet will have lb,ub,str on 00681 * the stack with the subscripted item beneath. 00682 * The expressions are as written in the source, 00683 * so make a zero-based OPC_TRIPLET, & push it. 00684 * 00685 *=============================================== 00686 */ 00687 00688 extern void 00689 fei_subscr_src_triplet(TYPE result_type ) 00690 { 00691 WN *lb ; 00692 WN *ub ; 00693 WN *str ; 00694 WN *wt ; 00695 WN *wn; 00696 00697 if (cwh_stk_get_class() == WN_item) { 00698 wn = cwh_stk_pop_WN(); 00699 str = wn; 00700 }else 00701 str = cwh_expr_operand(NULL) ; 00702 00703 if (cwh_stk_get_class() == WN_item) { 00704 wn = cwh_stk_pop_WN(); 00705 ub = wn; 00706 }else 00707 ub = cwh_expr_operand(NULL) ; 00708 00709 if (cwh_stk_get_class() == WN_item) { 00710 wn = cwh_stk_pop_WN(); 00711 lb = wn; 00712 }else 00713 lb = cwh_expr_operand(NULL) ; 00714 00715 wt = cwh_addr_src_triplet(lb,ub,str); 00716 00717 cwh_stk_push(wt,WN_item); 00718 } 00719 00720 /*=============================================== 00721 * 00722 * fei_subscr_size 00723 * 00724 * An axis size description is on the stack - 00725 * stride multiplier, extent, and declared lb. An 00726 * OPC_ARRAY/ARRSECTION doesn't need the size - it 00727 * uses the declared size, so this routine just 00728 * saves the state of the bounds_check flag 00729 * 00730 *=============================================== 00731 */ 00732 extern void 00733 fei_subscr_size( TYPE result_type, INT32 bounds_check) 00734 { 00735 check_bounds_this_access = (bounds_check != 0) && (cwh_io_in_ioblock==0); 00736 } 00737 00738 /*=============================================== 00739 * 00740 * fei_substr 00741 * 00742 * A substring operator for character types. 00743 * the stack contains the size,lb and address. 00744 * Make the address & length into a STR_item. 00745 * 00746 * Convert the substring details to an OPC_ARRAY 00747 * so the bounds of the substring are established 00748 * as a 1d array of chars (bytes). 00749 * 00750 * If there is an address (WN) on the stack, eg: 00751 * an OPC_ARRAY or OPC_ARRSECTION - we have an 00752 * character array reference, so just wrap the 00753 * OPC_ARRAY of the substring around the address. 00754 * If not, convert the ST (scalar character varbl) 00755 * into an address, then wrap it. FLDs are similar. 00756 * 00757 *=============================================== 00758 */ 00759 00760 extern void 00761 fei_substr(INT32 bounds_check) 00762 { 00763 WN * asz; 00764 WN * sz ; 00765 WN * lb ; 00766 WN * one; 00767 WN * ar ; 00768 TY_IDX ts ; 00769 00770 W_node ad ; 00771 FLD_det det ; 00772 00773 sz = cwh_expr_operand(NULL); 00774 lb = cwh_expr_operand(NULL); 00775 00776 switch(cwh_stk_get_class()){ 00777 case ST_item: 00778 case ST_item_whole_array: 00779 case WN_item: 00780 case WN_item_whole_array: 00781 ts = cwh_stk_get_TY(); 00782 ad = cwh_addr_substr_util(0,ts); 00783 break; 00784 00785 case DEREF_item: 00786 ad = cwh_addr_substr_util(0,0); 00787 break; 00788 00789 case FLD_item: 00790 det = cwh_addr_offset() ; 00791 ad = cwh_addr_substr_util(det.off,det.type) ; 00792 break ; 00793 00794 default: 00795 DevAssert((0),(" Odd string")); 00796 } 00797 00798 one = WN_CreateIntconst (opc_pint,1); 00799 lb = cwh_addr_zero_based(lb,one); 00800 asz = WN_COPY_Tree(sz); 00801 ar = cwh_addr_add_bound(W_wn(ad),asz,lb); 00802 00803 cwh_stk_push_STR(sz,ar,W_ty(ad),WN_item); 00804 } 00805 00806 /*=============================================== 00807 * 00808 * fei_addr 00809 * 00810 * Compute the address of TOS & push it back. This 00811 * used as a flag when context isn't sufficient to 00812 * tell the TOS is an address, eg: computing 00813 * the address of an element & storing into a 00814 * compiler temp. 00815 * 00816 *=============================================== 00817 */ 00818 extern void 00819 fei_addr(TYPE basic) 00820 { 00821 WN * wn ; 00822 00823 wn = cwh_expr_address(f_T_SAVED); 00824 if (cwh_addr_is_array(wn)) { 00825 /* need to "hide" this so that expr operand won't deref it if other 00826 * operations are done to it. 00827 */ 00828 wn = WN_CreateComma(OPCODE_make_op(OPR_COMMA,Pointer_Mtype,MTYPE_V), 00829 WN_CreateBlock(),wn); 00830 00831 } 00832 cwh_stk_push(wn,ADDR_item); 00833 } 00834 00835 /*=============================================== 00836 * 00837 * fei_as_ref 00838 * 00839 * TOS is the address of a non-contiguous array, 00840 * created by fei_dv_deref. Turn it into 00841 * an OPC_ARRSECTION & push it back. Uses the 00842 * general DV routines to extract information, 00843 * so each setup & result is on the stack. 00844 * 00845 * The dope bounds are in fortran order & 00846 * WHIRL bounds in C order 00847 * 00848 *=============================================== 00849 */ 00850 extern void 00851 fei_as_ref( TYPE result_type ) 00852 { 00853 WN * ub; 00854 WN * ad; 00855 WN * sz; 00856 ST * st; 00857 TY_IDX ty; 00858 00859 TYPE_ID bt; 00860 INT32 nd,i; 00861 00862 ad = cwh_stk_pop_DEREF(); 00863 st = WN_st(ad); 00864 nd = cwh_types_dope_rank(ST_type(st)); 00865 ty = cwh_types_dope_basic_TY(ST_type(st)); 00866 ad = cwh_addr_array(opc_section,ad,ty); 00867 bt = cwh_bound_int_typeid; 00868 00869 for (i = 0 ; i < nd ; i++) { 00870 00871 cwh_stk_push(st,ST_item); 00872 fei_get_dv_extent(nd-i,0); 00873 sz = cwh_stk_pop_WN(); 00874 ub = cwh_expr_bincalc(OPR_SUB,WN_COPY_Tree(sz),WN_Intconst(bt,1)) ; 00875 ub = cwh_addr_triplet(WN_Intconst(bt,0),ub,WN_Intconst(bt,1)) ; 00876 ad = cwh_addr_add_bound(ad,sz,ub); 00877 } 00878 cwh_stk_push(ad,WN_item); 00879 } 00880 00881 /*=============================================== 00882 * 00883 * cwh_addr_array 00884 * 00885 * create an OPC_ARRAY or OPC_ARRSECTION 00886 * for the given address & TY. 00887 * 00888 *=============================================== 00889 */ 00890 static WN * 00891 cwh_addr_array(OPCODE op, WN * addr, TY_IDX ty) 00892 { 00893 WN * wn ; 00894 TY_IDX aty ; 00895 INT16 nkids,i ; 00896 00897 aty = cwh_types_array_TY(ty); 00898 00899 TY& t = Ty_Table[aty]; 00900 nkids = 2 * TY_AR_ndims(t) +1 ; 00901 00902 wn = WN_Create ( op, nkids ); 00903 WN_element_size(wn) = TY_size(TY_etype(t)); 00904 00905 WN_kid(wn,0) = addr ; 00906 00907 FOREACH_AXIS(i,nkids) { 00908 WN_kid(wn,i+SZ_OFF(nkids)) = NULL ; 00909 WN_kid(wn,i+SUB_OFF(nkids)) = NULL ; 00910 } 00911 return wn ; 00912 } 00913 00914 00915 static WN * 00916 cwh_addr_array1(OPCODE op, WN * addr, TY_IDX ty,INT32 kidsnum) 00917 { 00918 WN * wn ; 00919 TY_IDX aty ; 00920 INT16 nkids,i ; 00921 00922 aty = cwh_types_array_TY(ty); 00923 00924 TY& t = Ty_Table[aty]; 00925 // nkids = 2 * TY_AR_ndims(t) +1 ; 00926 nkids = 2 * kidsnum +1 ; 00927 00928 /*since co_array's co_rank could be not appearing,we cannot */ 00929 /*use TY_AR_ndims as kids number,have to use kids number */ 00930 /* from Cray IR -----June */ 00931 00932 wn = WN_Create ( op, nkids ); 00933 WN_element_size(wn) = TY_size(TY_etype(t)); 00934 00935 WN_kid(wn,0) = addr ; 00936 00937 FOREACH_AXIS(i,nkids) { 00938 WN_kid(wn,i+SZ_OFF(nkids)) = NULL ; 00939 WN_kid(wn,i+SUB_OFF(nkids)) = NULL ; 00940 } 00941 return wn ; 00942 } 00943 00944 00945 00946 /*================================================================ 00947 * 00948 * cwh_addr_do_bounds_check 00949 * 00950 * Implement the bounds checking stuff 00951 * 00952 * inputs: 00953 * WN * subscript - a subscript expression, in user space 00954 * (i.e. not lbound normalized. If it's a TRIPLET, its 00955 * lower bound has not yet been normalized. 00956 * 00957 * WN * lbound - declared lower bound. 00958 * WN * extent - size of the index. 00959 * 00960 * returns: logical expression (or NULL) which indicates whether the bounds check passed 00961 * A NULL means that no bounds check should be done. 00962 * 00963 *================================================================ 00964 */ 00965 static WN * 00966 cwh_addr_do_bounds_check(WN *subscript_in, WN *lbound, WN *extent) 00967 { 00968 WN *lbc,*ubc,*assertion,*subscript; 00969 WN *stride,*ub,*ubdecl; 00970 WN *arrexp; 00971 WN *temp; 00972 static OPCODE ge_op=OPCODE_UNKNOWN,lt_op=OPCODE_UNKNOWN,le_op=OPCODE_UNKNOWN; 00973 static TYPE log_type; 00974 PREG_NUM bc_preg; 00975 00976 if (!DEBUG_Subscript_Check || !check_bounds_this_access) return (NULL); 00977 if (ge_op == OPCODE_UNKNOWN) { 00978 ge_op = OPCODE_make_op(OPR_GE,MTYPE_I4,cwh_bound_int_typeid); 00979 lt_op = OPCODE_make_op(OPR_LT,MTYPE_I4,cwh_bound_int_typeid); 00980 le_op = OPCODE_make_op(OPR_LE,MTYPE_I4,cwh_bound_int_typeid); 00981 t_TY(log_type) = cast_to_int(logical4_ty); 00982 } 00983 00984 ubdecl = cwh_expr_bincalc(OPR_ADD,WN_COPY_Tree(lbound),WN_COPY_Tree(extent)); 00985 00986 /* Wrap an ARRAYEXP if necessary */ 00987 subscript = F90_Wrap_ARREXP(subscript_in); 00988 00989 if (WNOPR(subscript)==OPR_SRCTRIPLET) { 00990 /* Three cases: stride constant and positive, constant and negative, non-constant */ 00991 stride = WN_kid1(subscript); 00992 ub = cwh_addr_ubound_from_triplet(subscript); 00993 00994 if (WNOPR(stride) != OPR_INTCONST) { 00995 /* Check that the lower bound is OK */ 00996 temp = WN_CreateExp2(ge_op,WN_COPY_Tree(WN_kid0(subscript)),WN_COPY_Tree(lbound)); 00997 lbc = WN_CreateExp2(lt_op,WN_COPY_Tree(WN_kid0(subscript)),WN_COPY_Tree(ubdecl)); 00998 lbc = WN_LAND(temp,lbc); 00999 01000 /* Check that the upper bound is OK */ 01001 temp = WN_CreateExp2(ge_op,WN_COPY_Tree(ub),WN_COPY_Tree(lbound)); 01002 ubc = WN_CreateExp2(lt_op,WN_COPY_Tree(ub),ubdecl); 01003 ubc = WN_LAND(temp,ubc); 01004 } else { 01005 /* Constant stride */ 01006 if (WN_const_val(stride) > 0) { 01007 /* Only need to check lb > declared lb and ub < declared ub */ 01008 lbc = WN_CreateExp2(ge_op,WN_COPY_Tree(WN_kid0(subscript)),WN_COPY_Tree(lbound)); 01009 ubc = WN_CreateExp2(lt_op,WN_COPY_Tree(ub),ubdecl); 01010 } else { 01011 /* check that first element is < top, last > bottom */ 01012 lbc = WN_CreateExp2(lt_op,WN_COPY_Tree(WN_kid0(subscript)),ubdecl); 01013 ubc = WN_CreateExp2(ge_op,WN_COPY_Tree(ub),WN_COPY_Tree(lbound)); 01014 } 01015 } 01016 assertion = WN_LAND(lbc,ubc); 01017 01018 } else if (WNOPR(subscript)==OPR_ARRAYEXP) { 01019 /* Array expression, need to build up an ANY node */ 01020 arrexp = WN_COPY_Tree(subscript); 01021 lbc = WN_CreateExp2(ge_op,WN_COPY_Tree(WN_kid0(subscript)),WN_COPY_Tree(lbound)); 01022 ubc = WN_CreateExp2(lt_op,WN_COPY_Tree(WN_kid0(arrexp)),ubdecl); 01023 assertion = WN_LAND(lbc,ubc); 01024 WN_kid0(arrexp) = assertion; 01025 cwh_stk_push(arrexp,WN_item); 01026 fei_null_expr(); 01027 fei_all(log_type); 01028 assertion = cwh_expr_operand(NULL); 01029 bc_preg = Create_Preg(MTYPE_I4,"bounds_check"); 01030 cwh_block_append(WN_StidPreg(MTYPE_I4,bc_preg,assertion)); 01031 assertion = WN_LdidPreg(MTYPE_I4,bc_preg); 01032 } else { 01033 /* Scalar expression */ 01034 lbc = WN_CreateExp2(ge_op,WN_COPY_Tree(subscript),WN_COPY_Tree(lbound)); 01035 ubc = WN_CreateExp2(lt_op,WN_COPY_Tree(subscript),ubdecl); 01036 assertion = WN_LAND(lbc,ubc); 01037 } 01038 if (WNOPR(assertion) == OPR_INTCONST) { 01039 if (WN_const_val(assertion) != 0) { 01040 /* Assertion is always true, don't need to check it */ 01041 WN_DELETE_Tree(assertion); 01042 return (NULL); 01043 } 01044 } 01045 return (assertion); 01046 } 01047 01048 /*================================================================ 01049 * 01050 * cwh_addr_insert_bounds_check 01051 * 01052 * Implement the bounds checking stuff 01053 * 01054 * inputs: 01055 * WN * assertion - a logical expression which is TRUE if everyting is OK with the access 01056 * WN * ar - an ARRAY node (only partially filled in) so that the name and axis number can be 01057 * determined. The array_name_map is used to figure out the array name. 01058 * 01059 *================================================================ 01060 */ 01061 static void 01062 cwh_addr_insert_bounds_check(WN *assertion, WN *ar) 01063 { 01064 WN *args[4]; 01065 BOOL byval[4]; 01066 WN *save_block,*fail_block; 01067 char *proc_name; 01068 char *array_name; 01069 INT axis,ndim; 01070 INT64 lineno; 01071 01072 if (assertion == NULL) return; 01073 01074 /* Figure out the axis */ 01075 ndim = WN_num_dim(ar); 01076 for (axis = 0; axis < ndim; axis++) { 01077 if (WN_array_dim(ar,axis) == NULL) break; 01078 } 01079 axis = ndim - axis; /* convert to user axis number */ 01080 01081 /* Figure out the name */ 01082 01083 01084 /* make up the IF */ 01085 fail_block = WN_CreateBlock(); 01086 assertion = WN_CreateIf(assertion, WN_CreateBlock(), fail_block); 01087 cwh_block_append(assertion); 01088 save_block = cwh_block_exchange_current(fail_block); 01089 01090 /* build up the intrinsic call */ 01091 lineno = USRCPOS_linenum(current_srcpos); 01092 args[1] = WN_Intconst(MTYPE_I4,lineno); 01093 byval[1] = TRUE; 01094 /* proc_name = ST_name(Procedure_ST); */ 01095 proc_name = cwh_dst_filename_from_filenum(SRCPOS_filenum(current_srcpos)); 01096 args[0] = WN_LdaString(proc_name, 0, strlen(proc_name)); 01097 byval[0] = TRUE; 01098 01099 array_name = GET_ARRAY_NAME_MAP(ar); 01100 if (array_name) { 01101 args[2] = WN_LdaString(array_name, 0, strlen(array_name)+1); 01102 } else { 01103 args[2] = WN_Intconst(Pointer_Mtype,0); 01104 } 01105 byval[2] = TRUE; 01106 args[3] = WN_Intconst(MTYPE_I4,axis); 01107 byval[3] = TRUE; 01108 cwh_intrin_call(INTRN_F90BOUNDS_CHECK, 4, args, NULL, byval, MTYPE_V); 01109 cwh_block_set_current(save_block); 01110 } 01111 01112 /*=============================================== 01113 * 01114 * cwh_addr_add_bound 01115 * 01116 * Add the size and subscript to the given 01117 * OPC_ARRAY or OPC_ARRSECTION. When the 01118 * node was created, the kids were nulled. 01119 * Look for the first free kid. (Axes 01120 * are processed high to 1, but WH requires C order) 01121 * 01122 * Return the modified WN. 01123 * 01124 *=============================================== 01125 */ 01126 static WN * 01127 cwh_addr_add_bound(WN * ar, WN * sz, WN *subscript) 01128 { 01129 INT16 nkids,i ; 01130 01131 nkids = WN_kid_count(ar) ; 01132 01133 FOREACH_AXIS(i,nkids) { 01134 if (WN_kid(ar,i) == NULL) { 01135 WN_kid(ar,i+SZ_OFF(nkids)) = sz; 01136 WN_kid(ar,i+SUB_OFF(nkids)) = subscript ; 01137 break ; 01138 } 01139 } 01140 01141 01142 return ar ; 01143 } 01144 01145 /*=============================================== 01146 * 01147 * cwh_addr_use_mstid_mldid 01148 * 01149 * Given an ST, and the WHIRL flag, see if the 01150 * ST is a candidate for mldid/mstid. There is a 01151 * test, because the F90 lowerer does not do 01152 * dependency checking on mldid/mstid. It does 01153 * on the more general mload/mstore. 01154 * 01155 *=============================================== 01156 */ 01157 01158 static inline bool 01159 cwh_addr_use_mstid_mldid(ST *st) 01160 { 01161 BOOL res = WHIRL_Mldid_Mstid_On && 01162 !ST_is_equivalenced(st) && 01163 !ST_is_f90_target(st); 01164 01165 return res ; 01166 } 01167 01168 /*=============================================== 01169 * 01170 * cwh_addr_ldid 01171 * 01172 * Given an ST, offset and ty, make an LDID. If 01173 * the ST is a dummy the ty will be KIND_POINTER 01174 * and the address loaded. 01175 * 01176 *=============================================== 01177 */ 01178 extern WN * 01179 cwh_addr_ldid(ST *st, OFFSET_64 off, TY_IDX ty) 01180 { 01181 01182 WN * wn ; 01183 TYPE_ID bt ; 01184 01185 if (cwh_addr_use_mstid_mldid(st)) { 01186 01187 if (TY_kind(ty) != KIND_SCALAR && TY_kind(ty) != KIND_STRUCT) 01188 bt = Pointer_Mtype; 01189 else 01190 bt = TY_mtype(ty); 01191 01192 } else { 01193 01194 if (TY_kind(ty) != KIND_SCALAR) 01195 bt = Pointer_Mtype; 01196 else 01197 bt = TY_mtype(ty); 01198 } 01199 01200 if (BIG_OFFSET(off)) { 01201 wn = cwh_addr_lda(st,off,ty); 01202 wn = cwh_addr_iload(wn,0,ty); 01203 01204 } else { 01205 01206 wn = cwh_addr_mk_ldid(st,off,bt,ty); 01207 } 01208 cwh_addr_access_flags(st,ACCESSED_LOAD); 01209 return (wn) ; 01210 } 01211 01212 /*=============================================== 01213 * 01214 * cwh_addr_mk_ldid 01215 * 01216 * Given an ST,offset,type id and ty, make an LDID. 01217 * The opcode of the LDID is derived from rt, and 01218 * the WN_ty from the ty. This is just a lookup 01219 * of the opcode, so suitable for odd return 01220 * temps and so forth. Does not deal with large 01221 * offsets. 01222 * 01223 *=============================================== 01224 */ 01225 extern WN * 01226 cwh_addr_mk_ldid(ST *st, OFFSET_64 off, TYPE_ID bt, TY_IDX ty) 01227 { 01228 01229 WN * wn ; 01230 OPCODE opc ; 01231 01232 opc = Ldid_Opcode [bt]; 01233 01234 if (cwh_addr_use_mstid_mldid(st)) { 01235 01236 if (TY_size(ty) != MTYPE_byte_size (bt) && 01237 TY_kind(ty) != KIND_STRUCT) 01238 Set_TY_IDX_index (ty, TY_IDX_index (MTYPE_To_TY (bt))); 01239 01240 } else { 01241 01242 if (TY_size(ty) != MTYPE_byte_size (bt)) 01243 Set_TY_IDX_index (ty, TY_IDX_index (MTYPE_To_TY (bt))); 01244 } 01245 01246 wn = WN_CreateLdid (opc,off,st,ty) ; 01247 01248 return wn ; 01249 } 01250 01251 /*=============================================== 01252 * 01253 * cwh_addr_mload 01254 * 01255 * Given a WN which is an address, an offset and 01256 * scalar ty, make an OPC_MLOAD. 01257 * 01258 *=============================================== 01259 */ 01260 01261 extern WN * 01262 cwh_addr_mload(WN *wt, OFFSET_64 off, TY_IDX ty, WN * sz) 01263 { 01264 WN * wn ; 01265 TY_IDX tp ; 01266 01267 if (cwh_addr_f90_pointer_reference(wt)) { 01268 tp = cwh_types_mk_f90_pointer_ty(ty); 01269 } else { 01270 tp = cwh_types_make_pointer_type(ty, FALSE); 01271 } 01272 01273 if (BIG_OFFSET(off)) { 01274 wt = cwh_expr_bincalc(OPR_ADD,wt,WN_Intconst(Pointer_Mtype,off)); 01275 off = 0; 01276 } 01277 01278 if (! sz) 01279 sz = WN_CreateIntconst (opc_pint, TY_size(ty)) ; 01280 01281 wn = WN_CreateMload(off,tp,wt,sz); 01282 01283 return (wn) ; 01284 } 01285 01286 /*=============================================== 01287 * 01288 * cwh_addr_iload 01289 * 01290 * Given an WN which is an address, an offset 01291 * and scalar ty, make an OPC_ILOAD. 01292 * 01293 *=============================================== 01294 */ 01295 static WN * 01296 cwh_addr_iload(WN *wt, OFFSET_64 off, TY_IDX ty) 01297 { 01298 WN * wn ; 01299 TY_IDX tp ; 01300 OPCODE op; 01301 01302 if (cwh_addr_f90_pointer_reference(wt)) { 01303 tp = cwh_types_mk_f90_pointer_ty(ty); 01304 } else { 01305 tp = cwh_types_make_pointer_type(ty, FALSE); 01306 } 01307 01308 if (BIG_OFFSET(off)) { 01309 wt = cwh_expr_bincalc(OPR_ADD,wt,WN_Intconst(Pointer_Mtype,off)); 01310 off = 0; 01311 } 01312 op = Load_Opcode [TY_mtype(ty)]; 01313 wn = WN_CreateIload (op,off,ty,tp,wt); 01314 01315 return (wn) ; 01316 } 01317 01318 /*=================================================== 01319 * 01320 * cwh_addr_WN_ST 01321 * 01322 * Given a WN, find the ST of what it addresses. Not 01323 * general - used in figuring out STs when building 01324 * addresses. 01325 * 01326 ==================================================== 01327 */ 01328 01329 extern ST * 01330 cwh_addr_WN_ST(WN * wn) 01331 { 01332 ST * st = NULL ; 01333 WN *kid; 01334 INT i; 01335 01336 switch (WNOPR(wn)) { 01337 case OPR_ARRAY: 01338 case OPR_ARRSECTION: 01339 case OPR_ARRAYEXP: 01340 case OPR_ILOAD: 01341 st = cwh_addr_WN_ST(WN_kid0(wn)); 01342 break ; 01343 01344 case OPR_LDA: 01345 case OPR_LDID: 01346 st = WN_st(wn) ; 01347 break; 01348 01349 case OPR_INTCONST: 01350 /* return a NULL st */ 01351 break; 01352 01353 /* Special case for ADD */ 01354 case OPR_ADD: 01355 for (i=0; i <= 1; i++) { 01356 kid = WN_kid(wn,i); 01357 switch (WNOPR(kid)) { 01358 case OPR_ARRAY: 01359 case OPR_ARRSECTION: 01360 case OPR_ARRAYEXP: 01361 case OPR_LDA: 01362 case OPR_LDID: 01363 case OPR_ILOAD: 01364 st = cwh_addr_WN_ST(kid); 01365 return (st); 01366 } 01367 } 01368 /* Fall through */ 01369 01370 default: 01371 DevAssert((OPCODE_is_expression(WN_opcode(wn))),(" Unexpected WN")); 01372 break; 01373 } 01374 01375 return (st) ; 01376 } 01377 01378 /*=============================================== 01379 * 01380 * cwh_addr_load_WN 01381 * 01382 * Given a WN which is an address, make an OPC_ILOAD or 01383 * OPC_MLOAD. If TY argument dty is null, the type 01384 * will be inferred from the WN. Dty tends to be 01385 * used for derived type components. 01386 * 01387 *=============================================== 01388 */ 01389 extern WN * 01390 cwh_addr_load_WN(WN * awn, OFFSET_64 off, TY_IDX dty) 01391 { 01392 TY_IDX ty ; 01393 TY_IDX ts ; 01394 WN * wn; 01395 01396 if (dty == 0) 01397 ty = cwh_types_WN_TY(awn,FALSE); 01398 else 01399 ty = dty ; 01400 01401 switch(TY_kind(ty)) { 01402 01403 case KIND_POINTER: 01404 case KIND_SCALAR : 01405 wn = cwh_addr_iload(awn,off,ty); 01406 break ; 01407 01408 case KIND_ARRAY : 01409 ts = cwh_types_scalar_TY(ty); 01410 if (TY_kind(ts) == KIND_STRUCT) 01411 wn = cwh_addr_mload(awn,off,ts, NULL); 01412 else 01413 wn = cwh_addr_iload(awn,off,ts); 01414 break; 01415 01416 case KIND_STRUCT : 01417 ts = cwh_types_scalar_TY(ty); 01418 wn = cwh_addr_mload(awn,off,ts, NULL); 01419 break ; 01420 01421 default: 01422 DevAssert((0),("unimplemented WN load")); 01423 break; 01424 } 01425 01426 return (wn); 01427 } 01428 01429 /*=============================================== 01430 * 01431 * cwh_addr_load_ST 01432 * 01433 * Given a ST make an LDID, ILOAD or MLOAD. The ST 01434 * may be a basic or a derived type. The TY argument 01435 * may be NULL unless addressing a component of 01436 * a derived type, although it will be used if present. 01437 * 01438 *=============================================== 01439 */ 01440 extern WN * 01441 cwh_addr_load_ST(ST * st, OFFSET_64 off, TY_IDX dty) 01442 { 01443 01444 WN * wn; 01445 WN * wa; 01446 TY_IDX ts; 01447 TY_IDX ty; 01448 01449 INT fg ; 01450 01451 ty = ST_type(st); 01452 fg = ACCESSED_LOAD; 01453 01454 switch (ST_sclass(st)) { 01455 case SCLASS_FORMAL: 01456 if (dty) 01457 ts = dty; 01458 else if (TY_kind(ty) == KIND_POINTER) 01459 ts = TY_pointed(ty); 01460 else 01461 ts = ty; 01462 01463 if (BY_VALUE(ty)) { 01464 wn = cwh_addr_ldid(st,off,ts); 01465 } else { 01466 wa = cwh_addr_address_ST(st); 01467 wn = cwh_addr_load_WN(wa,off,ts); 01468 } 01469 break ; 01470 01471 case SCLASS_AUTO: 01472 case SCLASS_FSTATIC: 01473 case SCLASS_PSTATIC: 01474 case SCLASS_REG: 01475 case SCLASS_COMMON: 01476 case SCLASS_DGLOBAL: 01477 case SCLASS_FORMAL_REF: 01478 case SCLASS_MODULE: 01479 case SCLASS_COMMON1: 01480 01481 switch(TY_kind(ty)) { 01482 01483 case KIND_POINTER : 01484 fg |= ACCESSED_STORE | ACCESSED_ILOAD | ACCESSED_ISTORE|ACCESSED_PSTORE; 01485 01486 case KIND_SCALAR : 01487 01488 ts = (dty ? dty : ty); 01489 if (ST_class(st)==CLASS_VAR && ST_auxst_is_auto_or_cpointer(st)) { 01490 /* need to load it through its base */ 01491 wa = cwh_addr_address_ST(st); 01492 wn = cwh_addr_load_WN(wa,0,ts); 01493 fg |= ACCESSED_ILOAD; 01494 } else { 01495 wn = cwh_addr_ldid(st,off,ts); 01496 } 01497 break ; 01498 01499 case KIND_ARRAY : 01500 01501 wa = cwh_addr_address_ST(st,off); 01502 wn = cwh_addr_load_WN(wa,0,0); 01503 01504 01505 break ; 01506 01507 case KIND_STRUCT : 01508 ts = (dty ? dty : ty); 01509 01510 if (cwh_addr_use_mstid_mldid(st)) { 01511 01512 if (TY_kind(ts) == KIND_POINTER){ /* dope */ 01513 fg |= ACCESSED_STORE | ACCESSED_ILOAD | ACCESSED_ISTORE|ACCESSED_PSTORE; 01514 } 01515 wn = cwh_addr_ldid(st,off,ts); 01516 } 01517 else { 01518 if (TY_kind(ts) == KIND_SCALAR) 01519 wn = cwh_addr_ldid(st,off,ts); 01520 01521 else if (TY_kind(ts) == KIND_POINTER){ /* dope */ 01522 fg |= ACCESSED_STORE | ACCESSED_ILOAD | ACCESSED_ISTORE|ACCESSED_PSTORE; 01523 wn = cwh_addr_ldid(st,off,ts); 01524 01525 } else { 01526 wa = cwh_addr_address_ST(st,off,ts); 01527 wn = cwh_addr_load_WN(wa,0,ts); 01528 } 01529 } 01530 break ; 01531 01532 default: 01533 DevAssert((0),("unimplemented ST load")); 01534 break; 01535 } 01536 break ; 01537 01538 default: 01539 DevAssert((0),("Odd ST load")); 01540 break; 01541 } 01542 01543 cwh_addr_access_flags(st,fg); 01544 return (wn); 01545 } 01546 01547 /*=================================================== 01548 * 01549 * cwh_addr_pstid 01550 * 01551 * Create an OPC_PSTID, given an ST, offset, ty 01552 * and a rhs WN. If a derived type component the 01553 * offset and TY need not be those of the ST. 01554 * 01555 ==================================================== 01556 */ 01557 extern WN * 01558 cwh_addr_pstid(ST *st, OFFSET_64 off, TY_IDX ty , WN * rhs) 01559 { 01560 WN * wn ; 01561 WN * wt ; 01562 TY_IDX tl ; 01563 01564 TYPE t ; 01565 TYPE_ID bt; 01566 OPCODE op; 01567 01568 01569 if (BIG_OFFSET(off)) { 01570 wn = cwh_addr_lda(st,off,ty); 01571 wn = cwh_addr_pstore(wn,0,ty,rhs); 01572 01573 } else { 01574 01575 tl = ty; 01576 bt = TY_mtype(ty) ; 01577 01578 # if ! defined (linux) 01579 if (IS_ALTENTRY_TEMP(st)) { 01580 if (MTYPE_is_integral(bt)) { 01581 tl = cwh_stab_altentry_TY(st,TRUE); 01582 st = ST_base(st); 01583 bt = TY_mtype(tl); 01584 01585 } else if (! ST_auxst_altentry_shareTY(ST_base(st))) { 01586 01587 if ((bt == MTYPE_C4) && (ST_ofst(st) != 0)) { 01588 01589 op = Stid_Opcode [bt]; 01590 wn = WN_CreatePStid (op,off,st,ty,WN_COPY_Tree(rhs)); 01591 cwh_block_append(wn); 01592 01593 bt = MTYPE_F4; 01594 tl = Be_Type_Tbl(bt); 01595 wt = cwh_convert_to_ty(WN_COPY_Tree(rhs),bt); 01596 op = PStid_Opcode [bt]; 01597 wn = WN_CreatePStid (op,4,ST_base(st),tl,wt); 01598 cwh_block_append(wn); 01599 01600 t_TY((t)) = cast_to_uint(tl); 01601 cwh_stk_push(rhs,WN_item); 01602 fei_imag(t); 01603 rhs = cwh_stk_pop_WN(); 01604 off = 12; 01605 st = ST_base(st); 01606 01607 } 01608 } 01609 } 01610 # endif 01611 01612 op = PStid_Opcode [bt]; 01613 wn = WN_CreatePStid (op,off,st,tl,rhs); 01614 } 01615 01616 cwh_addr_access_flags(st,ACCESSED_STORE); 01617 return (wn); 01618 } 01619 01620 01621 /*=================================================== 01622 * 01623 * cwh_addr_stid 01624 * 01625 * Create an OPC_STID, given an ST, offset, ty 01626 * and a rhs WN. If a derived type component the 01627 * offset and TY need not be those of the ST. 01628 * 01629 ==================================================== 01630 */ 01631 extern WN * 01632 cwh_addr_stid(ST *st, OFFSET_64 off, TY_IDX ty , WN * rhs) 01633 { 01634 WN * wn ; 01635 WN * wt ; 01636 TY_IDX tl ; 01637 01638 TYPE t ; 01639 TYPE_ID bt; 01640 OPCODE op; 01641 01642 if (!(TY_kind(ty)== KIND_POINTER)) //left hand is pointer skip this 01643 rhs = cwh_convert_to_ty(rhs, TY_mtype(ty)); 01644 01645 if (BIG_OFFSET(off)) { 01646 wn = cwh_addr_lda(st,off,ty); 01647 wn = cwh_addr_istore(wn,0,ty,rhs); 01648 01649 } else { 01650 01651 tl = ty; 01652 bt = TY_mtype(ty) ; 01653 01654 # if ! defined (linux) 01655 if (IS_ALTENTRY_TEMP(st)) { 01656 if (MTYPE_is_integral(bt)) { 01657 tl = cwh_stab_altentry_TY(st,TRUE); 01658 st = ST_base(st); 01659 bt = TY_mtype(tl); 01660 01661 } else if (! ST_auxst_altentry_shareTY(ST_base(st))) { 01662 01663 if ((bt == MTYPE_C4) && (ST_ofst(st) != 0)) { 01664 01665 op = Stid_Opcode [bt]; 01666 wn = WN_CreateStid (op,off,st,ty,WN_COPY_Tree(rhs)); 01667 cwh_block_append(wn); 01668 01669 bt = MTYPE_F4; 01670 tl = Be_Type_Tbl(bt); 01671 wt = cwh_convert_to_ty(WN_COPY_Tree(rhs),bt); 01672 op = Stid_Opcode [bt]; 01673 wn = WN_CreateStid (op,4,ST_base(st),tl,wt); 01674 cwh_block_append(wn); 01675 01676 t_TY((t)) = cast_to_uint(tl); 01677 cwh_stk_push(rhs,WN_item); 01678 fei_imag(t); 01679 rhs = cwh_stk_pop_WN(); 01680 off = 12; 01681 st = ST_base(st); 01682 01683 } 01684 } 01685 } 01686 # endif 01687 01688 op = Stid_Opcode [bt]; 01689 wn = WN_CreateStid (op,off,st,tl,rhs); 01690 } 01691 01692 cwh_addr_access_flags(st,ACCESSED_STORE); 01693 return (wn); 01694 } 01695 01696 /*=================================================== 01697 * 01698 * cwh_addr_istore 01699 * 01700 * Create an OPC_ISTORE, given an address, offset, 01701 * scalar ty and a rhs. 01702 * 01703 ==================================================== 01704 */ 01705 extern WN * 01706 cwh_addr_istore(WN * lhs, OFFSET_64 off, TY_IDX ty, WN * rhs) 01707 { 01708 WN * wn ; 01709 TY_IDX tp ; 01710 OPCODE op ; 01711 01712 if (cwh_addr_f90_pointer_reference(lhs)) { 01713 tp = cwh_types_mk_f90_pointer_ty(ty); 01714 } else { 01715 tp = cwh_types_make_pointer_type(ty, FALSE); 01716 } 01717 01718 if (BIG_OFFSET(off)) { 01719 lhs = cwh_expr_bincalc(OPR_ADD,lhs,WN_Intconst(Pointer_Mtype,off)); 01720 off = 0; 01721 } 01722 /* rhs = cwh_convert_to_ty(rhs, TY_mtype(ty)); 01723 * for SOURCE_TO_SOURCE level WHIRL we can keep 01724 * the different types in an expression without 01725 * OPR_CVT added 01726 *---fzhao 01727 */ 01728 op = Store_Opcode [TY_mtype(ty)]; 01729 wn = WN_CreateIstore(op,off,tp,rhs,lhs); 01730 01731 return (wn); 01732 } 01733 01734 01735 /*=================================================== 01736 * 01737 * cwh_addr_pstore 01738 * 01739 * Create an OPC_PSTORE, given an address, offset, 01740 * scalar ty and a rhs. 01741 * 01742 ==================================================== 01743 */ 01744 extern WN * 01745 cwh_addr_pstore(WN * lhs, OFFSET_64 off, TY_IDX ty, WN * rhs) 01746 { 01747 WN * wn ; 01748 TY_IDX tp ; 01749 OPCODE op ; 01750 01751 if (cwh_addr_f90_pointer_reference(lhs)) { 01752 tp = cwh_types_mk_f90_pointer_ty(ty); 01753 } else { 01754 tp = cwh_types_make_pointer_type(ty, FALSE); 01755 } 01756 01757 if (BIG_OFFSET(off)) { 01758 lhs = cwh_expr_bincalc(OPR_ADD,lhs,WN_Intconst(Pointer_Mtype,off)); 01759 off = 0; 01760 } 01761 op = PStore_Opcode [TY_mtype(ty)]; 01762 wn = WN_CreatePstore(op,off,tp,rhs,lhs); 01763 01764 return (wn); 01765 } 01766 01767 /*=================================================== 01768 * 01769 * cwh_addr_mstore 01770 * 01771 * Create an OPC_MSTORE, given address,offset, 01772 * ty and rhs WN. TY is type of store, eg: of 01773 * derived type conponent. 01774 * 01775 ==================================================== 01776 */ 01777 extern WN * 01778 cwh_addr_mstore(WN * ad, OFFSET_64 off, TY_IDX ty, WN * rhs) 01779 { 01780 TY_IDX tp ; 01781 WN * wn ; 01782 WN * sz ; 01783 01784 if (cwh_addr_f90_pointer_reference(ad)) { 01785 tp = cwh_types_mk_f90_pointer_ty(ty); 01786 } else { 01787 tp = cwh_types_make_pointer_type(ty, FALSE); 01788 } 01789 01790 if (BIG_OFFSET(off)) { 01791 ad = cwh_expr_bincalc(OPR_ADD,ad,WN_Intconst(Pointer_Mtype,off)); 01792 off = 0; 01793 } 01794 sz = WN_CreateIntconst (opc_pint, TY_size(ty)) ; 01795 wn = WN_CreateMstore (off,tp,rhs,ad,sz); 01796 01797 return (wn); 01798 } 01799 01800 /*=================================================== 01801 * 01802 * cwh_addr_store_ST 01803 * 01804 * Create the appropriate store, given an ST. The 01805 * argument TY will be NULL, unless it's a store of 01806 * component of a derived type. 01807 * 01808 ==================================================== 01809 */ 01810 extern void 01811 cwh_addr_store_ST(ST * st, OFFSET_64 off, TY_IDX dty, WN * rhs) 01812 { 01813 WN * wn; 01814 WN * wa; 01815 TY_IDX ts; 01816 TY_IDX ty; 01817 INT fg ; 01818 01819 ty = ST_type(st); 01820 fg = ACCESSED_STORE; 01821 01822 switch (ST_sclass(st)) { 01823 01824 case SCLASS_FORMAL: 01825 if (dty) 01826 ts = dty; 01827 else if (TY_kind(ty) == KIND_POINTER) 01828 ts = TY_pointed(ty); 01829 else 01830 ts = ty; 01831 01832 if (BY_VALUE(ty)) { 01833 wn = cwh_addr_stid(st,0,ts,rhs); 01834 cwh_block_append(wn) ; 01835 01836 } else { 01837 wa = cwh_addr_address_ST(st); 01838 cwh_addr_store_WN(wa,off,ts,rhs); 01839 } 01840 break ; 01841 01842 case SCLASS_AUTO: 01843 case SCLASS_PSTATIC: 01844 case SCLASS_FSTATIC: 01845 case SCLASS_REG: 01846 case SCLASS_COMMON: 01847 case SCLASS_DGLOBAL: 01848 case SCLASS_FORMAL_REF: 01849 case SCLASS_MODULE: 01850 case SCLASS_COMMON1: 01851 01852 ts = (dty ? dty : ty); 01853 switch(TY_kind(ty)) { 01854 01855 case KIND_POINTER: 01856 fg |= ACCESSED_LOAD | ACCESSED_ILOAD | ACCESSED_ISTORE|ACCESSED_PSTORE; 01857 01858 case KIND_SCALAR : 01859 if (ST_class(st)==CLASS_VAR && ST_auxst_is_auto_or_cpointer(st)) { 01860 wa = cwh_addr_address_ST(st); 01861 cwh_addr_store_WN(wa,off,0,rhs); 01862 fg |= ACCESSED_ISTORE|ACCESSED_PSTORE; 01863 01864 } else { 01865 wn = cwh_addr_stid(st,off,ts,rhs); 01866 01867 if (still_in_preamble) 01868 cwh_block_append_given_id(wn,First_Block,FALSE); 01869 else 01870 cwh_block_append(wn) ; 01871 01872 /* if CQ function result & shared entry temp */ 01873 /* store via the result address too */ 01874 01875 # if ! defined (linux) 01876 if (IS_ALTENTRY_TEMP(st)) { 01877 if (TY_mtype(ts) == MTYPE_CQ){ 01878 if(!ST_auxst_altentry_shareTY(ST_base(st))) { 01879 wn = cwh_addr_load_ST(st,0,NULL); 01880 cwh_addr_store_ST(Altaddress_ST,0,NULL,wn); 01881 } 01882 } 01883 } 01884 # endif 01885 01886 /* if in preamble, may be storing bound, or character length */ 01887 /* set the COPYIN flag. This is just for temps created by */ 01888 /* by whirlconvert, those created by the FE will be in the */ 01889 /* preamble block, via fei_array_dimen */ 01890 01891 if (still_in_preamble) 01892 cwh_types_copyin_pragma(st); 01893 } 01894 break ; 01895 01896 case KIND_ARRAY: 01897 wa = cwh_addr_address_ST(st,off); 01898 cwh_addr_store_WN(wa,0,0,rhs); 01899 break ; 01900 01901 case KIND_STRUCT: 01902 if ( cwh_addr_use_mstid_mldid(st)) { 01903 01904 if(TY_kind(ts) == KIND_POINTER){ /* dope */ 01905 fg |= ACCESSED_LOAD | ACCESSED_ILOAD | ACCESSED_ISTORE|ACCESSED_PSTORE; 01906 } 01907 wn = cwh_addr_stid(st,off,ts,rhs); 01908 cwh_block_append(wn) ; 01909 01910 } else { 01911 01912 if (TY_kind(ts) == KIND_SCALAR) { 01913 wn = cwh_addr_stid(st,off,ts,rhs); 01914 cwh_block_append(wn) ; 01915 01916 } else if(TY_kind(ts) == KIND_POINTER){ /* dope */ 01917 fg |= ACCESSED_LOAD | ACCESSED_ILOAD | ACCESSED_ISTORE|ACCESSED_PSTORE; 01918 wn = cwh_addr_stid(st,off,ts,rhs); 01919 cwh_block_append(wn) ; 01920 01921 } else { 01922 wa = cwh_addr_address_ST(st,off); 01923 cwh_addr_store_WN(wa,0,ts,rhs); 01924 } 01925 } 01926 break ; 01927 01928 default: 01929 DevAssert((0),("Odd ST store")); 01930 break; 01931 } 01932 break ; 01933 01934 default: 01935 DevAssert((0),("Odd ST store")); 01936 break; 01937 } 01938 cwh_addr_access_flags(st,fg); 01939 } 01940 01941 /*=================================================== 01942 * 01943 * cwh_addr_pstore_ST 01944 * 01945 * Create the appropriate store, given an ST. The 01946 * argument TY will be NULL, unless it's a store of 01947 * component of a derived type. 01948 * 01949 ==================================================== 01950 */ 01951 extern void 01952 cwh_addr_pstore_ST(ST * st, OFFSET_64 off, TY_IDX dty, WN * rhs) 01953 { 01954 WN * wn; 01955 WN * wa; 01956 TY_IDX ts; 01957 TY_IDX ty; 01958 INT fg ; 01959 01960 ty = ST_type(st); 01961 fg = ACCESSED_PSTORE; 01962 01963 switch (ST_sclass(st)) { 01964 01965 case SCLASS_FORMAL: 01966 if (dty) 01967 ts = dty; 01968 else if (TY_kind(ty) == KIND_POINTER) 01969 ts = TY_pointed(ty); 01970 else 01971 ts = ty; 01972 01973 if (BY_VALUE(ty)) { 01974 wn = cwh_addr_pstid(st,0,ts,rhs); 01975 cwh_block_append(wn) ; 01976 01977 } else { 01978 wa = cwh_addr_address_ST(st); 01979 cwh_addr_pstore_WN(wa,off,ts,rhs); 01980 } 01981 break ; 01982 01983 case SCLASS_AUTO: 01984 case SCLASS_PSTATIC: 01985 case SCLASS_FSTATIC: 01986 case SCLASS_REG: 01987 case SCLASS_COMMON: 01988 case SCLASS_DGLOBAL: 01989 case SCLASS_FORMAL_REF: 01990 case SCLASS_MODULE: 01991 case SCLASS_COMMON1: 01992 01993 ts = (dty ? dty : ty); 01994 switch(TY_kind(ty)) { 01995 01996 case KIND_POINTER: 01997 fg |= ACCESSED_LOAD | ACCESSED_ILOAD | ACCESSED_ISTORE|ACCESSED_PSTORE; 01998 01999 case KIND_SCALAR : 02000 if (ST_class(st)==CLASS_VAR && ST_auxst_is_auto_or_cpointer(st)) { 02001 wa = cwh_addr_address_ST(st); 02002 cwh_addr_pstore_WN(wa,off,0,rhs); 02003 fg |= ACCESSED_ISTORE|ACCESSED_PSTORE; 02004 02005 } else { 02006 wn = cwh_addr_pstid(st,off,ts,rhs); 02007 cwh_block_append(wn) ; 02008 02009 /* if CQ function result & shared entry temp */ 02010 /* store via the result address too */ 02011 02012 # if ! defined (linux) 02013 if (IS_ALTENTRY_TEMP(st)) { 02014 if (TY_mtype(ts) == MTYPE_CQ){ 02015 if(!ST_auxst_altentry_shareTY(ST_base(st))) { 02016 wn = cwh_addr_load_ST(st,0,NULL); 02017 cwh_addr_pstore_ST(Altaddress_ST,0,NULL,wn); 02018 } 02019 } 02020 } 02021 # endif 02022 02023 /* if in preamble, may be storing bound, or character length */ 02024 /* set the COPYIN flag. This is just for temps created by */ 02025 /* by whirlconvert, those created by the FE will be in the */ 02026 /* preamble block, via fei_array_dimen */ 02027 02028 } 02029 break ; 02030 02031 case KIND_ARRAY: 02032 wa = cwh_addr_address_ST(st,off); 02033 cwh_addr_pstore_WN(wa,0,0,rhs); 02034 break ; 02035 02036 case KIND_STRUCT: 02037 if ( cwh_addr_use_mstid_mldid(st)) { 02038 02039 if(TY_kind(ts) == KIND_POINTER){ /* dope */ 02040 fg |= ACCESSED_LOAD | ACCESSED_ILOAD | ACCESSED_ISTORE|ACCESSED_PSTORE; 02041 } 02042 wn = cwh_addr_pstid(st,off,ts,rhs); 02043 cwh_block_append(wn) ; 02044 02045 } else { 02046 02047 if (TY_kind(ts) == KIND_SCALAR) { 02048 wn = cwh_addr_pstid(st,off,ts,rhs); 02049 cwh_block_append(wn) ; 02050 02051 } else if(TY_kind(ts) == KIND_POINTER){ /* dope */ 02052 fg |= ACCESSED_LOAD | ACCESSED_ILOAD | ACCESSED_ISTORE|ACCESSED_PSTORE; 02053 wn = cwh_addr_pstid(st,off,ts,rhs); 02054 cwh_block_append(wn) ; 02055 02056 } else { 02057 wa = cwh_addr_address_ST(st,off); 02058 cwh_addr_pstore_WN(wa,0,ts,rhs); 02059 } 02060 } 02061 break ; 02062 02063 default: 02064 DevAssert((0),("Odd ST store")); 02065 break; 02066 } 02067 break ; 02068 02069 default: 02070 DevAssert((0),("Odd ST store")); 02071 break; 02072 } 02073 cwh_addr_access_flags(st,fg); 02074 } 02075 02076 02077 /*=================================================== 02078 * 02079 * cwh_addr_store_WN 02080 * 02081 * Create an OPC_ISTORE, or OPC_MSTORE given an 02082 * address and WN. Use the TY of the address, unless 02083 * the the TY argument is not NULL, when it's 02084 * probably a derived type component. 02085 * 02086 * Add conversions to RHS if required. 02087 * 02088 ==================================================== 02089 */ 02090 extern void 02091 cwh_addr_store_WN(WN * lhs, OFFSET_64 off, TY_IDX dty, WN * rhs) 02092 { 02093 WN * wn ; 02094 TY_IDX ts ; 02095 TY_IDX ty ; 02096 02097 if (dty) 02098 ty = dty ; 02099 else 02100 ty = cwh_types_WN_TY(lhs,FALSE); 02101 02102 switch(TY_kind(ty)) { 02103 02104 case KIND_SCALAR: 02105 case KIND_POINTER: 02106 wn = cwh_addr_istore(lhs,off,ty,rhs); 02107 break ; 02108 02109 case KIND_ARRAY: 02110 ts = cwh_types_scalar_TY(ty); 02111 if (TY_kind(ts) == KIND_STRUCT) 02112 wn = cwh_addr_mstore(lhs,off,ts,rhs); 02113 else 02114 wn = cwh_addr_istore(lhs,off,ts,rhs); 02115 break; 02116 02117 case KIND_STRUCT: 02118 wn = cwh_addr_mstore(lhs,off,ty,rhs); 02119 break ; 02120 02121 default: 02122 DevAssert((0),("Odd WN store")); 02123 wn = NULL; 02124 break; 02125 } 02126 if (wn!=NULL) 02127 cwh_block_append(wn) ; 02128 } 02129 02130 /*=================================================== 02131 * 02132 * cwh_addr_pstore_WN 02133 * 02134 * Create an OPC_PSTORE, or OPC_MSTORE given an 02135 * address and WN. Use the TY of the address, unless 02136 * the the TY argument is not NULL, when it's 02137 * probably a derived type component. 02138 * 02139 * Add conversions to RHS if required. 02140 * 02141 ==================================================== 02142 */ 02143 extern void 02144 cwh_addr_pstore_WN(WN * lhs, OFFSET_64 off, TY_IDX dty, WN * rhs) 02145 { 02146 WN * wn ; 02147 TY_IDX ts ; 02148 TY_IDX ty ; 02149 02150 if (dty) 02151 ty = dty ; 02152 else 02153 ty = cwh_types_WN_TY(lhs,FALSE); 02154 02155 switch(TY_kind(ty)) { 02156 02157 case KIND_SCALAR: 02158 case KIND_POINTER: 02159 wn = cwh_addr_pstore(lhs,off,ty,rhs); 02160 break ; 02161 02162 case KIND_ARRAY: 02163 ts = cwh_types_scalar_TY(ty); 02164 if (TY_kind(ts) == KIND_STRUCT) 02165 wn = cwh_addr_mstore(lhs,off,ts,rhs); 02166 else 02167 wn = cwh_addr_pstore(lhs,off,ts,rhs); 02168 break; 02169 02170 case KIND_STRUCT: 02171 wn = cwh_addr_mstore(lhs,off,ty,rhs); 02172 break ; 02173 02174 default: 02175 DevAssert((0),("Odd WN store")); 02176 } 02177 02178 cwh_block_append(wn) ; 02179 } 02180 02181 /*=============================================== 02182 * 02183 * cwh_addr_address_ST 02184 * 02185 * 02186 * Given a ST make an LDA of its address, unless 02187 * it's a formal, then make an LDID. 02188 * 02189 * For BASED variables, we load the BASE if its 02190 * not a COMMON or static base. 02191 * 02192 * Offset and ty are optional and default to 02193 * 0 and the TY of the ST. Otherwise the TY 02194 * is the type associated with an offset within 02195 * a struct. the lda routine will make this into 02196 * a pointer. 02197 * 02198 *=============================================== 02199 */ 02200 extern WN * 02201 cwh_addr_address_ST(ST * st, OFFSET_64 off, TY_IDX ty) 02202 { 02203 WN * wn ; 02204 INT fg ; 02205 TY_IDX tp; 02206 02207 if (ty == 0) { 02208 if (ST_class(st) == CLASS_FUNC) 02209 ty = ST_pu_type(st); 02210 else 02211 ty = ST_type(st); 02212 } 02213 02214 switch (ST_sclass(st)){ 02215 case SCLASS_FORMAL: 02216 02217 DevAssert((TY_kind(ty) == KIND_POINTER),("formal & non-pointer")); 02218 02219 wn = cwh_addr_ldid(st,0,ty); 02220 if (off != 0) 02221 wn = cwh_expr_bincalc(OPR_ADD,wn,WN_Intconst(Pointer_Mtype,off)); 02222 02223 fg = ACCESSED_LOAD|ACCESSED_ILOAD|ACCESSED_ISTORE|ACCESSED_PSTORE ; 02224 cwh_addr_access_flags(st,fg); 02225 break; 02226 02227 default: 02228 if (Has_Base_Block(st) && ST_auxst_is_auto_or_cpointer(st)) { 02229 02230 tp = cwh_types_make_pointer_type(ty,FALSE); 02231 wn = cwh_addr_ldid(ST_base(st),0,tp); 02232 if (off != 0) 02233 wn = cwh_expr_bincalc(OPR_ADD,wn,WN_Intconst(Pointer_Mtype,off)); 02234 } else { 02235 wn = cwh_addr_lda(st,off,ty) ; 02236 } 02237 break; 02238 } 02239 02240 return (wn); 02241 } 02242 02243 /*=================================================== 02244 * 02245 * cwh_addr_lda 02246 * 02247 * Make an LDA for an ST. The TY is that of the object 02248 * - a pointer TY will be made here. 02249 * 02250 ==================================================== 02251 */ 02252 static WN * 02253 cwh_addr_lda(ST * st, OFFSET_64 off, TY_IDX ty) 02254 { 02255 TY_IDX tp ; 02256 WN * wn ; 02257 INT fg ; 02258 02259 tp = cwh_types_make_pointer_type(ty, FALSE); 02260 02261 /* cwh_expr_set_flags(st, f_USED_LOCALLY); */ 02262 02263 if (BIG_OFFSET(off)) { 02264 wn = WN_CreateLda (opc_lda,0,tp,st); 02265 wn = cwh_expr_bincalc(OPR_ADD,wn,WN_Intconst(Pointer_Mtype,off)); 02266 02267 } else { 02268 wn = WN_CreateLda (opc_lda,off,tp,st); 02269 } 02270 02271 fg = ACCESSED_LOAD|ACCESSED_ILOAD ; 02272 cwh_addr_access_flags(st,fg); 02273 02274 return (wn); 02275 } 02276 02277 /*=============================================== 02278 * 02279 * cwh_addr_triplet 02280 * 02281 * Make an OPC_TRIPLET - we get an upper bound, 02282 * but need an extent. 02283 * 02284 *=============================================== 02285 */ 02286 static WN * 02287 cwh_addr_triplet(WN *lb,WN *ub,WN *str) 02288 { 02289 WN * wn ; 02290 02291 wn = WN_Create (opc_triplet, 3) ; 02292 WN_kid0(wn) = lb; 02293 if (ub == NULL) 02294 WN_kid2(wn) = lb ; 02295 else 02296 if ( WNOPR(ub)== OPR_IMPLICIT_BND) 02297 WN_kid2(wn) = ub; 02298 else 02299 WN_kid2(wn) = cwh_addr_extent(lb,ub,str); 02300 02301 WN_kid1(wn) = str; 02302 02303 return (wn); 02304 } 02305 /*=============================================== 02306 * 02307 * cwh_addr_src_triplet 02308 * 02309 * Make an OPC_SRCTRIPLET - we get an upper bound, 02310 * but need an extent. 02311 * 02312 *=============================================== 02313 */ 02314 static WN * 02315 cwh_addr_src_triplet(WN *lb,WN *ub,WN *str) 02316 { 02317 WN * wn ; 02318 02319 wn = WN_Create (opc_src_triplet, 3) ; 02320 WN_kid0(wn) = lb; 02321 WN_kid1(wn) = ub; 02322 WN_kid2(wn) = str; 02323 02324 return (wn); 02325 } 02326 02327 /*=============================================== 02328 * 02329 * cwh_addr_zero_based 02330 * 02331 * Make an WN subscript zero based. A triplet 02332 * was created as specified in the source text, 02333 * so make the lower bound zero based. 02334 * 02335 *=============================================== 02336 */ 02337 static WN * 02338 cwh_addr_zero_based(WN *sub, WN * lb) 02339 { 02340 02341 if (cwh_addr_is_triplet(sub)) 02342 WN_kid0(sub) = cwh_expr_bincalc(OPR_SUB,WN_kid0(sub),lb); 02343 else 02344 sub = cwh_expr_bincalc(OPR_SUB,sub,lb); 02345 02346 return (sub); 02347 } 02348 02349 /*=============================================== 02350 * 02351 * cwh_addr_extent 02352 * 02353 * Make an extent from a ub, lb, str. 02354 * all nodes are copied, 02355 * 02356 *=============================================== 02357 */ 02358 extern WN * 02359 cwh_addr_extent(WN * lb, WN * ub, WN * str) 02360 { 02361 WN * wt ; 02362 WN * wub ; 02363 WN * wlb ; 02364 WN * ws1 ; 02365 WN * ws2 ; 02366 02367 ws1 = WN_COPY_Tree(str) ; 02368 ws2 = WN_COPY_Tree(str); 02369 wlb = WN_COPY_Tree(lb) ; 02370 wub = WN_COPY_Tree(ub); 02371 02372 wt = cwh_expr_bincalc(OPR_SUB,wub,wlb); 02373 wt = cwh_expr_bincalc(OPR_ADD,wt,ws1); 02374 wt = cwh_expr_bincalc(OPR_DIV,wt,ws2); 02375 02376 return (wt); 02377 } 02378 02379 /*=============================================== 02380 * 02381 * cwh_addr_ubound_from_triplet 02382 * 02383 * Make get a ubound from a triplet 02384 * 02385 *=============================================== 02386 */ 02387 extern WN * 02388 cwh_addr_ubound_from_triplet(WN * triplet) 02389 { 02390 WN *lb; 02391 WN *st; 02392 WN *ex; 02393 WN *ub; 02394 02395 lb = WN_COPY_Tree(WN_kid0(triplet)); 02396 st = WN_COPY_Tree(WN_kid1(triplet)); 02397 ex = WN_COPY_Tree(WN_kid2(triplet)); 02398 02399 /* UB = LB + ST*(EX-1) */ 02400 ex = cwh_expr_bincalc(OPR_SUB,ex,WN_Intconst(cwh_bound_int_typeid,1)); 02401 02402 ub = cwh_expr_bincalc(OPR_MPY,ex,st); 02403 ub = cwh_expr_bincalc(OPR_ADD,ub,lb); 02404 02405 return (ub); 02406 } 02407 02408 02409 02410 /*=============================================== 02411 * 02412 * cwh_addr_adjust_array 02413 * 02414 * The element size of this OPC_ARRAY or 02415 * OPC_ARRSECTION was unknown. Make the element 02416 * size 1, the address 0, and add it to a pointer. 02417 * Used for characters whose len type parameter is 02418 * unknown. 02419 * 02420 *=============================================== 02421 */ 02422 static WN * 02423 cwh_addr_adjust_array(WN *wn, TY_IDX ty) 02424 { 02425 02426 WN * sz ; 02427 WN * extent; 02428 TY_IDX tl ; 02429 INT i,ndim; 02430 02431 ndim = WN_num_dim(wn); 02432 /* use the new spiffy non-contiguous array addressing method */ 02433 WN_element_size(wn) = -1; 02434 02435 if (TY_kind(TY_AR_etype(ty)) == KIND_ARRAY) { 02436 02437 tl = TY_AR_etype(ty); 02438 02439 sz = cwh_types_bound_WN(tl,0,UPPER); 02440 for (i=ndim-1; i >= 0; i--) { 02441 extent = WN_array_dim(wn,i); 02442 WN_array_dim(wn,i) = sz; 02443 sz = cwh_expr_bincalc(OPR_MPY,extent,WN_COPY_Tree(sz)); 02444 } 02445 WN_DELETE_Tree(sz); 02446 } 02447 02448 return(wn); 02449 } 02450 /*=============================================== 02451 * 02452 * cwh_addr_offset 02453 * 02454 * TOS is a FLD_item. Look below and pop any 02455 * FLD_items, accumulating the offset and 02456 * returning the type of the innermost field (TOS). 02457 * 02458 *=============================================== 02459 */ 02460 extern FLD_det 02461 cwh_addr_offset(void) 02462 { 02463 FLD_det det ; 02464 FLD_HANDLE fld (cwh_stk_pop_FLD()); 02465 02466 det.off = FLD_ofst(fld); 02467 det.type = FLD_type(fld); 02468 02469 while (cwh_stk_get_class() == FLD_item) 02470 det.off += FLD_ofst(FLD_HANDLE (cwh_stk_pop_FLD())); 02471 02472 return(det); 02473 } 02474 02475 /*=============================================== 02476 * 02477 * cwh_addr_is_* 02478 * 02479 * Is this WN an OPC_* 02480 * 02481 *=============================================== 02482 */ 02483 extern BOOL 02484 cwh_addr_is_array(WN * wn) 02485 { 02486 return(WN_opcode(wn) == opc_array); 02487 } 02488 extern BOOL 02489 cwh_addr_is_section(WN * wn) 02490 { 02491 return(WN_opcode(wn) == opc_section); 02492 } 02493 static BOOL 02494 cwh_addr_is_triplet(WN * wn) 02495 { 02496 return(WN_opcode(wn) == opc_triplet || WN_opcode(wn) ==opc_src_triplet); 02497 } 02498 02499 /*=============================================== 02500 * 02501 * cwh_addr_find_section 02502 * 02503 * Sometimes an OPC_ARRSECTION has a load 02504 * on top. May be a unary operator too. See if 02505 * there's a section here. If not, return NULL. 02506 * 02507 * To find the section - use p_RETURN_SECTION. 02508 * To find the section's parent - use p_RETURN_PARENT. 02509 * (if a section exists, but doesn't have a parent 02510 * the section itself is returned). 02511 * 02512 *=============================================== 02513 */ 02514 extern WN * 02515 cwh_addr_find_section(WN * awn , enum p_flag flag) 02516 { 02517 WN * wn = NULL ; 02518 02519 if (awn == NULL) 02520 return (wn); 02521 02522 switch (WNOPR(awn)){ 02523 case OPR_ARRSECTION: 02524 wn = awn ; 02525 break; 02526 02527 case OPR_ARRAYEXP: 02528 wn = cwh_addr_find_section(WN_kid0(awn),flag); 02529 break; 02530 02531 case OPR_ARRAY: 02532 case OPR_ILOAD: 02533 case OPR_MLOAD: 02534 wn = cwh_addr_find_section(WN_kid0(awn),flag); 02535 if (wn == WN_kid0(awn)) 02536 if (flag == p_RETURN_PARENT) 02537 wn = awn; 02538 02539 break; 02540 02541 case OPR_ADD: 02542 case OPR_SUB: 02543 wn = cwh_addr_find_section(WN_kid0(awn),flag); 02544 02545 if (wn == WN_kid0(awn)) 02546 if (flag == p_RETURN_PARENT) 02547 wn = awn; 02548 02549 if (wn == NULL) { 02550 wn = cwh_addr_find_section(WN_kid1(awn),flag); 02551 if (wn == WN_kid1(awn)) { 02552 if (flag == p_RETURN_PARENT) 02553 wn = awn; 02554 } 02555 } 02556 break; 02557 02558 default: 02559 wn = NULL; 02560 break; 02561 } 02562 return(wn) ; 02563 } 02564 02565 /*=============================================== 02566 * 02567 * cwh_addr_find_address 02568 * 02569 * Find the load of the address under the WN, 02570 * and return it. 02571 * 02572 *=============================================== 02573 */ 02574 extern WN * 02575 cwh_addr_find_address(WN * wn) 02576 { 02577 02578 switch (WNOPR(wn)){ 02579 case OPR_ILOAD: 02580 case OPR_MLOAD: 02581 case OPR_LDA: 02582 break; 02583 02584 case OPR_ARRAY: 02585 case OPR_ARRSECTION: 02586 case OPR_ARRAYEXP: 02587 wn = cwh_addr_find_address(WN_kid0(wn)); 02588 break ; 02589 02590 case OPR_LDID: 02591 break ; 02592 02593 default: 02594 if (OPCODE_is_expression(WN_opcode(wn))) 02595 wn = cwh_addr_find_address(WN_kid0(wn)); 02596 02597 } 02598 return(wn) ; 02599 } 02600 02601 /*=============================================== 02602 * 02603 * cwh_addr_substr_util 02604 * 02605 * Utility routine for fei_substr. If the 02606 * character varbl is a component of a derived 02607 * then then offset and dtype are passed in & used. 02608 * Otherwise the offset passed is 0 & the TY may have 02609 * to be found. Pop the address TOS and convert 02610 * it into an OPC_ARRAY of chars. Return the 02611 * OPC_ARRAY to get the substring bounds filled in. 02612 * 02613 * For a character array whose length type parameter 02614 * is a variable, TY_size == 0 in the OPC_ARRAY (of 02615 * the array, not substring). Make the element size 02616 * 1 & offset the address by the len=size * subscript. 02617 * 02618 * substring TY is a KIND_ARRAY of chars, so array of 02619 * substrings is ARRAY of ARRAY of chars.. 02620 * 02621 *=============================================== 02622 */ 02623 static W_node 02624 cwh_addr_substr_util(OFFSET_64 off, TY_IDX dty ) 02625 { 02626 TY_IDX ty ; 02627 TY_IDX te ; 02628 ST * st ; 02629 WN * ad ; 02630 W_node r; 02631 02632 ty = dty ; 02633 02634 if (cwh_stk_get_class() == ST_item || cwh_stk_get_class() == ST_item_whole_array) { 02635 02636 st = cwh_stk_pop_ST(); 02637 if (ty == 0) 02638 ty = ST_type(st); 02639 ad = cwh_addr_address_ST(st,off,ty); 02640 02641 ty = cwh_types_array_TY(ty); 02642 02643 } else { 02644 02645 ad = cwh_expr_address(f_NONE); 02646 02647 if (ty == 0) { 02648 ty = cwh_types_WN_TY(ad,TRUE); 02649 ty = cwh_types_array_TY(ty); 02650 } 02651 02652 if (WNOPR(ad) == OPR_ARRSECTION || WNOPR(ad) == OPR_ARRAY) 02653 if (WN_element_size(ad) == 0) 02654 ad = cwh_addr_adjust_array(ad,ty); 02655 02656 ad = cwh_expr_bincalc(OPR_ADD,ad,WN_Intconst(Pointer_Mtype,off)); 02657 } 02658 02659 te = ty ; 02660 if (TY_kind(TY_AR_etype(ty)) == KIND_ARRAY) 02661 te = TY_AR_etype(ty); 02662 02663 W_wn(r) = cwh_addr_array(opc_array,ad,te); 02664 W_ty(r) = ty; 02665 02666 return(r); 02667 } 02668 02669 /*=============================================== 02670 * 02671 * cwh_addr_temp_section 02672 * 02673 * Given an address & a TY which describes an 02674 * array, make an OPC_ARRSECTION for the full 02675 * array. 02676 * 02677 *=============================================== 02678 */ 02679 02680 extern WN * 02681 cwh_addr_temp_section(WN * ad, TY_IDX ty) 02682 { 02683 WN * ar; 02684 WN * lb; 02685 WN * ub; 02686 WN * sz; 02687 WN * szmult; 02688 TY_IDX aty; 02689 BOOL noncontig; 02690 INT32 ndims; 02691 02692 02693 INT16 i ; 02694 02695 ar = cwh_addr_array(opc_section,ad,ty); 02696 if (WN_element_size(ar) <= 0) { 02697 aty = TY_AR_etype(cwh_types_array_TY(ty)); 02698 noncontig = TRUE; 02699 } else { 02700 noncontig = FALSE; 02701 } 02702 02703 ndims = TY_AR_ndims(Ty_Table[ty]); 02704 02705 if (noncontig) { 02706 WN_element_size(ar) = -1; 02707 sz = cwh_types_bound_WN(aty,0,UPPER); 02708 for (i = ndims-1 ; i >= 0 ; i--) { 02709 lb = cwh_types_bound_WN(ty,i,LOW); 02710 ub = cwh_types_bound_WN(ty,i,UPPER); 02711 szmult = cwh_expr_bincalc(OPR_ADD, 02712 cwh_addr_zero_based(WN_COPY_Tree(ub),WN_COPY_Tree(lb)), 02713 WN_Intconst(cwh_bound_int_typeid,1)) ; 02714 02715 lb = cwh_addr_triplet(lb,ub,WN_Intconst(cwh_bound_int_typeid,1)) ; 02716 printf("here2????\n"); 02717 02718 ar = cwh_addr_add_bound(ar,WN_COPY_Tree(sz),lb); 02719 sz = cwh_expr_bincalc(OPR_MPY,sz,szmult); 02720 } 02721 WN_DELETE_Tree(sz); /* Clean up */ 02722 } else { 02723 for (i = ndims-1 ; i >= 0 ; i--) { 02724 lb = cwh_types_bound_WN(ty,i,LOW); 02725 ub = cwh_types_bound_WN(ty,i,UPPER); 02726 sz = cwh_expr_bincalc(OPR_ADD, 02727 cwh_addr_zero_based(WN_COPY_Tree(ub),WN_COPY_Tree(lb)), 02728 WN_Intconst(cwh_bound_int_typeid,1)) ; 02729 02730 lb = cwh_addr_triplet(lb,ub,WN_Intconst(cwh_bound_int_typeid,1)) ; 02731 printf("here3333\n"); 02732 ar = cwh_addr_add_bound(ar,sz,lb); 02733 } 02734 } 02735 return(ar); 02736 } 02737 02738 /*=============================================== 02739 * 02740 * cwh_addr_nonc_util 02741 * 02742 * Utility function for fei_non_conform_store. 02743 * 02744 * One of the two WN trees is a 1d temp, and the 02745 * other isn't. Find the ARRSECTION for the temp 02746 * and make it describe the nd shape of the other 02747 * tree's ARRSECTION. If the 1d expression was 02748 * just a 1d ARRSECTION, then the new ARRSECTION 02749 * is returned via the arguments. 02750 * 02751 *=============================================== 02752 */ 02753 extern void 02754 cwh_addr_nonc_util(WN **aa, WN **bb) 02755 { 02756 WN *a ; 02757 WN *b ; 02758 WN *wn ; 02759 WN *as ; 02760 WN *bs ; 02761 WN *pa ; 02762 02763 WN *s1d ; 02764 WN *p1d ; 02765 WN **a1d ; 02766 WN *snd ; 02767 02768 INT16 ar ; 02769 INT16 br ; 02770 02771 a = *aa; 02772 b = *bb; 02773 as = cwh_addr_find_section(a,p_RETURN_SECTION); 02774 bs = cwh_addr_find_section(b,p_RETURN_SECTION); 02775 02776 DevAssert((as != NULL), ("missing section")); 02777 DevAssert((bs != NULL), ("missing section")); 02778 02779 ar = WN_kid_count(as); 02780 br = WN_kid_count(bs); 02781 02782 02783 /* find & revamp the 1d section */ 02784 02785 if (ar == br ) 02786 return ; 02787 02788 if (ar < br ) { 02789 02790 s1d = as ; 02791 p1d = a ; 02792 a1d = aa ; 02793 snd = bs ; 02794 02795 02796 } else { 02797 02798 s1d = bs ; 02799 p1d = b ; 02800 a1d = bb ; 02801 snd = as ; 02802 } 02803 02804 pa = cwh_addr_find_section(p1d,p_RETURN_PARENT); 02805 wn = cwh_addr_nonc_recast(s1d,snd) ; 02806 02807 if (pa != s1d) { 02808 02809 if (WN_kid0(pa) == s1d) 02810 WN_kid0(pa) = wn; 02811 else 02812 WN_kid1(pa) = wn; 02813 02814 wn = NULL; 02815 } else 02816 *a1d = wn ; 02817 } 02818 02819 /*=============================================== 02820 * 02821 * cwh_addr_nonc_recast 02822 * 02823 * Utility function for fei_non_conform_store. 02824 * 02825 * The first argument is an ARRSECTION of a 1d 02826 * temp. Make a new ARRSECTION with the same 02827 * shape as the second argument. Deletes the 02828 * 1d tree. 02829 * 02830 *=============================================== 02831 */ 02832 static WN * 02833 cwh_addr_nonc_recast(WN *wt, WN *wa) 02834 { 02835 WN * wn ; 02836 WN * sc0 ; 02837 WN * sc1 ; 02838 WN * zr0 ; 02839 WN * one ; 02840 WN * lin ; 02841 02842 INT16 nk ; 02843 INT16 i ; 02844 02845 BOOL dope ; 02846 02847 nk = WN_kid_count(wa); 02848 wn = WN_Create (opc_section,nk); 02849 WN_element_size(wn) = WN_element_size(wt) ; 02850 02851 dope = (WN_element_size(wa) < 0) ; 02852 02853 WN_kid(wn,0) = WN_kid(wt,0); 02854 WN_kid(wt,0) = NULL; 02855 02856 DevAssert((WN_kid_count(wt) == 3),(" Not 1d")); 02857 02858 FOREACH_AXIS(i,nk) { 02859 02860 /* find extent of axis, maybe in dope, or size of VV subscript */ 02861 02862 if (dope) { 02863 sc0 = WN_kid(wa,i+SUB_OFF(nk)); 02864 02865 if (WNOPR(sc0) == OPR_ARRAYEXP) 02866 sc0 = WN_kid(sc0,1); 02867 02868 else { 02869 DevAssert((WNOPR(sc0) == OPR_SRCTRIPLET),("nonc rhs")); 02870 sc0 = WN_COPY_Tree(WN_kid2(sc0)); 02871 } 02872 02873 } else 02874 sc0 = WN_COPY_Tree(WN_kid(wa,i+SZ_OFF(nk))) ; 02875 02876 sc1 = WN_COPY_Tree(sc0); 02877 zr0 = WN_Intconst(cwh_bound_int_typeid,0); 02878 one = WN_Intconst(cwh_bound_int_typeid,1); 02879 sc1 = cwh_expr_bincalc(OPR_SUB,sc1,one); 02880 one = WN_Intconst(cwh_bound_int_typeid,1); 02881 02882 WN_kid(wn,i+SZ_OFF(nk)) = sc0; 02883 WN_kid(wn,i+SUB_OFF(nk)) = cwh_addr_triplet(zr0,sc1,one); 02884 printf("here4444\n"); 02885 } 02886 02887 /* it may be there was an offset into the 1d temp, if so */ 02888 /* it was a linearization, so bump the address along */ 02889 02890 DevAssert((WNOPR(WN_kid(wt,1+SUB_OFF(2))) == OPR_SRCTRIPLET),(" No triplet")); 02891 02892 lin = WN_kid0(WN_kid(wt,1+SUB_OFF(2))); 02893 02894 if ((WNOPR(lin) != OPR_INTCONST) || 02895 (WN_const_val(lin) != 0)) { 02896 02897 lin = WN_COPY_Tree(lin); 02898 lin = cwh_expr_bincalc(OPR_MPY,lin,WN_CreateIntconst(opc_pint,WN_element_size(wt))); 02899 wn = cwh_expr_bincalc(OPR_ADD,lin,wn); 02900 } 02901 02902 WN_DELETE_Tree(wt); 02903 return wn ; 02904 } 02905 02906 02907 /*=============================================== 02908 * 02909 * cwh_addr_access_flags 02910 * 02911 * Set the given ACCESS ID flags on the given ST, 02912 * 02913 *=============================================== 02914 */ 02915 static void 02916 cwh_addr_access_flags(ST *st , INT fg) 02917 { 02918 02919 if (IN_NESTED_PU) 02920 if (HOST_ASSOCIATED(st)) { 02921 cwh_stab_add_pragma(st,(WN_PRAGMA_ACCESSED_FLAGS) fg ) ; 02922 } 02923 } 02924 02925 02926 /*=============================================== 02927 * 02928 * cwh_addr_init_target 02929 * 02930 * Initialize all variables which set up 02931 * target-dependent variables. eg: -n32/64. 02932 * 02933 *=============================================== 02934 */ 02935 02936 extern void 02937 cwh_addr_init_target(void) 02938 { 02939 02940 if (Pointer_Size == 4) { 02941 02942 opc_lda = OPC_U4LDA; 02943 opc_call = OPC_U4CALL ; 02944 opc_array = OPC_U4ARRAY; 02945 opc_pint = OPC_U4INTCONST; 02946 opc_sint = OPC_I4INTCONST; 02947 opc_section = OPC_U4ARRSECTION; 02948 opc_triplet = OPC_I4SRCTRIPLET ; 02949 opc_src_triplet = OPC_I4SRCTRIPLET ; 02950 cwh_addr_char_len_typeid = MTYPE_I4; 02951 cwh_bound_int_typeid = MTYPE_I4; 02952 cwh_doloop_typeid = MTYPE_I4; 02953 02954 } else { 02955 02956 opc_lda = OPC_U8LDA; 02957 opc_call = OPC_U8CALL ; 02958 opc_pint = OPC_U8INTCONST; 02959 opc_sint = OPC_I8INTCONST; 02960 opc_array = OPC_U8ARRAY; 02961 opc_section = OPC_U8ARRSECTION; 02962 opc_triplet = OPC_I8SRCTRIPLET ; 02963 opc_src_triplet = OPC_I8SRCTRIPLET ; 02964 cwh_addr_char_len_typeid = MTYPE_I4; 02965 cwh_bound_int_typeid = MTYPE_I8; 02966 cwh_doloop_typeid = MTYPE_I8; 02967 } 02968 cwh_types_init_target(); 02969 } 02970 02971 02972 02973 02974 /*================================================================ 02975 * 02976 * BOOL cwh_addr_f90_pointer_reference(WN *addr) 02977 * 02978 * Given an addressing node, this routine returns TRUE if 02979 * the ILOAD or ISTORE loads or stores to memory addressed by an 02980 * F90 pointer. It is only reliable if the WHIRL coming out of 02981 * the F90 lowerer has not had addressing nodes altered. 02982 * 02983 *================================================================ 02984 */ 02985 02986 /* This routines works on the LOAD/STORE instead of the addresses */ 02987 02988 static BOOL cwh_addr_f90_pointer_reference_ls(WN * ls) 02989 { 02990 OPERATOR opr; 02991 INT i,nkids; 02992 BOOL r; 02993 02994 opr = WN_operator(ls); 02995 switch (opr) { 02996 case OPR_LDID: 02997 case OPR_LDA: 02998 return (FALSE); 02999 03000 case OPR_ILOAD: 03001 case OPR_MLOAD: 03002 return ( cwh_addr_f90_pointer_reference(WN_kid0(ls))); 03003 03004 case OPR_ISTORE: 03005 case OPR_PSTORE: 03006 case OPR_MSTORE: 03007 return ( cwh_addr_f90_pointer_reference(WN_kid1(ls))); 03008 03009 default: 03010 nkids = WN_kid_count(ls); 03011 r = FALSE; 03012 for (i=0 ; i < nkids; i++) { 03013 r |= cwh_addr_f90_pointer_reference(WN_kid(ls,i)); 03014 } 03015 return (r); 03016 } 03017 } 03018 03019 extern BOOL 03020 cwh_addr_f90_pointer_reference(WN * addr) 03021 { 03022 OPERATOR opr; 03023 ST *st; 03024 opr = WN_operator(addr); 03025 03026 switch (opr) { 03027 case OPR_LDID: 03028 st = WN_st(addr); 03029 if (ST_class(st) == CLASS_VAR) { 03030 return (ST_auxst_is_f90_pointer(st)); 03031 } 03032 return (FALSE); 03033 03034 case OPR_LDA: 03035 #if 0 03036 st = WN_st(addr); 03037 if (ST_class(st) == CLASS_VAR) { 03038 return (ST_auxst_is_f90_pointer(st)); 03039 } 03040 #else 03041 return (FALSE); 03042 #endif 03043 03044 case OPR_ILOAD: 03045 case OPR_STRCTFLD: 03046 if (TY_is_f90_pointer(WN_load_addr_ty(addr)) || 03047 TY_is_f90_pointer(TY_pointed(WN_load_addr_ty(addr)))) { 03048 return (TRUE); 03049 } 03050 return (FALSE); 03051 03052 case OPR_ARRSECTION: 03053 case OPR_ARRAY: 03054 case OPR_ARRAYEXP: 03055 return (cwh_addr_f90_pointer_reference(WN_kid0(addr))); 03056 03057 case OPR_INTCONST: 03058 return (FALSE); 03059 03060 default: 03061 /* Treat as expression again */ 03062 return ( cwh_addr_f90_pointer_reference_ls (addr)); 03063 } 03064 } 03065 03066 03067 extern void 03068 fei_field_dot(TYPE type) 03069 { 03070 /* Doesn't do anything right now--old comments */ 03071 /* we need to generate a new operator for field of 03072 structure--FMZ */ 03073 OPCODE opc; 03074 WN * wn ; 03075 WN * kid0 = NULL; 03076 FLD_det det ; 03077 ST * st; 03078 FLD_HANDLE fld ; 03079 TY_IDX ty1,ty2; 03080 FLD_IDX fld_idx; 03081 TYPE_ID rt, dt; 03082 UINT field_id = 1; 03083 03084 fld_idx = cwh_stk_pop_FLD(); 03085 fld=FLD_HANDLE(fld_idx); 03086 det.off = FLD_ofst(fld); 03087 det.type = FLD_type(fld); 03088 ty1 = det.type; 03089 ty2 = cast_to_TY(t_TY(type)); 03090 03091 dt = MTYPE_U8; 03092 rt = MTYPE_U8; 03093 03094 switch(cwh_stk_get_class()) { 03095 case WN_item: 03096 kid0 = cwh_stk_pop_WN(); 03097 break; 03098 case ST_item: 03099 case ST_item_whole_array: 03100 st = cwh_stk_pop_ST(); 03101 kid0 = cwh_addr_address_ST(st,0,ty1); 03102 break; 03103 default: 03104 cwh_stk_pop_whatever() ; 03105 } 03106 03107 //get field_id by ty2 and fld_idx 03108 { 03109 FLD_HANDLE fld1; 03110 fld1 = TY_fld(ty2); 03111 while (fld1.Idx() != fld_idx && !FLD_last_field(fld1)){ 03112 field_id++; 03113 fld1 = FLD_next(fld1); 03114 } 03115 } 03116 03117 opc = OPCODE_make_op(OPR_STRCTFLD,rt,dt); 03118 wn = WN_Create(opc,1); 03119 WN_set_ty(wn,ty1); 03120 WN_set_load_addr_ty(wn,ty2); 03121 WN_set_field_id(wn, field_id); 03122 03123 03124 WN_kid0(wn) = kid0; 03125 03126 /* if ty1 is a pointer, generate an "ILOAD" to be the parent of STRCTFLD */ 03127 ty2 = fld.Entry()->type; 03128 if (TY_is_f90_pointer(ty2)){ 03129 kid0 = wn; 03130 ty2=TY_pointed(ty2); 03131 if (TY_is_f90_deferred_shape(ty2)) 03132 ty2 = TY_etype(ty2); 03133 opc = Load_Opcode[MTYPE_U8]; /* using MTYPE_U8 for pointer */ 03134 wn = WN_CreateIload(opc,0,ty2,ty2,kid0); 03135 } 03136 03137 cwh_stk_push_typed(wn,WN_item,ty1); 03138 03139 return; 03140 } 03141 03142 03143 extern WN* 03144 addr_gen_iload_for_strctfld(WN * wn) 03145 { 03146 OPCODE opc; 03147 WN *wni; 03148 TY_IDX ty; 03149 ty = WN_ty(wn); 03150 opc = Load_Opcode[TY_mtype(ty)]; 03151 wni= WN_CreateIload(opc,0,ty,ty,wn); 03152 return wni; 03153 03154 }