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 * 00041 * Revision history: 00042 * dd-mmm-95 - Original Version 00043 * 00044 * Description: contains routines to convert statements 00045 * from Cray IR to WHIRL. Entry points from 00046 * PDGCS layer are 00047 * 00048 * fei_stmt - start of new statement. 00049 * fei_user_code_start - begin of user statements 00050 * fei_object_ref - reference to object 00051 * fei_seg_ref - reference to segment 00052 * fei_namelist_ref - reference to namelist 00053 * fei_member_ref - reference to derived type component. 00054 * fei_constant - reference to constant. 00055 * fei_push_arith_con - reference to constant. 00056 * fei_push_pattern_con - reference to string or byte string 00057 * fei_function_ref - reference to procedure for call. 00058 * fei_label_ref - reference to a a label 00059 * 00060 * these routines generally push an ST/WN/STR item on the 00061 * stack for later processing. Statement level operations are 00062 * 00063 * fei_store - save rhs in lhs. 00064 * fei_non_conform_store - save 1d object in nd, or vice versa. 00065 * fei_call - make a procedure call 00066 * fei_arg_addr - make an address for a procedure argument. 00067 * feI_fcd - turn cray pointer ref into strinfg reference 00068 * fei_addr_con - generate the address of a constant 00069 * fei_entry_pt - generate an alternate entry point 00070 * fei_goto - create a goto. 00071 * fei_arith_goto - create arithmetic IF gotos. 00072 * fei_label_addr - create index for assign stmt. 00073 * fei_indirect_goto - use table for assign and computed goto. 00074 * fei_new_select - create a select case 00075 * fei_label_def_named - define a label within the code. 00076 * fei_brtrue - create a branch on TRUE 00077 * fei_where - the WHERE statement, TRUE only. 00078 * fei_return - a return statement 00079 * fei_concat - create an OPC_CASSIGNMENT for concatenation 00080 * fei_doloop - create an DOLOOP statemnet 00081 * fei_dowhile - create an DOWHILE statement 00082 * fei_doforever - create an DOWHILE TRUE statement 00083 * fei_enddo - back to parent block at end of DO loop. 00084 * fei_allocate - the (DE) ALLOCATE statement. 00085 * 00086 * 00087 * ==================================================================== 00088 * ==================================================================== 00089 */ 00090 00091 static char *source_file = __FILE__; 00092 00093 00094 /* sgi includes */ 00095 00096 #include "defs.h" 00097 #include "glob.h" 00098 #include "stab.h" 00099 #include "strtab.h" 00100 #include "errors.h" 00101 #include "targ_const.h" 00102 #include "config_targ.h" 00103 #include "config_debug.h" 00104 #include "const.h" 00105 #include "pu_info.h" 00106 #include "wn.h" 00107 #include "wn_util.h" 00108 #include "f90_utils.h" 00109 #include "targ_sim.h" 00110 00111 #include "s_call.m" 00112 00113 /* FE includes */ 00114 00115 #include "i_cvrt.h" 00116 00117 /* conversion includes */ 00118 00119 #include "cwh_defines.h" 00120 #include "cwh_addr.h" 00121 #include "cwh_block.h" 00122 #include "cwh_expr.h" 00123 #include "cwh_stk.h" 00124 #include "cwh_types.h" 00125 #include "cwh_preg.h" 00126 #include "cwh_stab.h" 00127 #include "cwh_auxst.h" 00128 #include "cwh_intrin.h" 00129 #include "cwh_stmt.h" 00130 #include "cwh_dst.h" 00131 #include "cwh_directive.h" 00132 #include "cwh_preg.h" 00133 #include "sgi_cmd_line.h" 00134 00135 #include "cwh_stmt.i" 00136 #include <stack> 00137 00138 typedef std::stack<int> STKT; 00139 STKT arg_association_info; 00140 00141 extern void 00142 fei_arg_associate(INT32 association) 00143 { 00144 arg_association_info.push(association); 00145 } 00146 00147 /*=============================================== 00148 * 00149 * fei_stmt 00150 * 00151 * Initialize data structures for WHIRL conversion 00152 * at the start of each statement. 00153 * 00154 * Set the current line number. 00155 * 00156 *=============================================== 00157 */ 00158 /*ARGSUSED*/ 00159 extern void 00160 fei_stmt(INT32 lineno, 00161 INT32 stmt_character_flag ) 00162 { 00163 00164 if (lineno) { 00165 00166 cwh_stmt_init_srcpos(lineno); 00167 00168 /* Insert any deferred statements */ 00169 00170 cwh_block_append_given(Defer_Block); 00171 } 00172 } 00173 00174 /*=============================================== 00175 * 00176 * fei_user_code_start 00177 * 00178 * Marks the beginning of user statements & end 00179 * of FE generated preamble (ie: saves to temps 00180 * for decls). Add whirl built for declaration 00181 * or pragma processing processing. 00182 * 00183 *=============================================== 00184 */ 00185 extern void 00186 fei_user_code_start(void) 00187 { 00188 still_in_preamble = FALSE; 00189 cwh_block_append_given(Preamble_Block); 00190 cwh_block_append_given(First_Block); 00191 cwh_stmt_add_pragma(WN_PRAGMA_PREAMBLE_END); 00192 (void) cwh_block_toggle_debug(TRUE) ; 00193 00194 cwh_stk_verify_empty(); 00195 } 00196 00197 /*=============================================== 00198 * 00199 * fei_object_ref 00200 * 00201 * Push a reference to an object (an ST) 00202 * on the expression stack. It may be an 00203 * lvalue, so don't fetch it. 00204 * 00205 *=============================================== 00206 */ 00207 /*ARGSUSED*/ 00208 extern void 00209 fei_object_ref (INTPTR sym_idx, 00210 INT32 whole_array, 00211 INT32 whole_substring ) 00212 { 00213 STB_pkt *p ; 00214 00215 if(sym_idx) { 00216 p = cast_to_STB(sym_idx); 00217 DevAssert((p->form == is_ST),("Odd object ref")); 00218 ST * st = cast_to_ST(p->item); 00219 DevAssert((st),("null st")); 00220 if (whole_array) { 00221 cwh_stk_push(st,ST_item_whole_array) ; 00222 } else { 00223 cwh_stk_push(st,ST_item) ; 00224 } 00225 } 00226 } 00227 00228 /*=============================================== 00229 * 00230 * fei_seg_ref 00231 * 00232 * Push a reference to an segment (eg. common block) (an ST) 00233 * on the expression stack. 00234 * 00235 *=============================================== 00236 */ 00237 extern void 00238 fei_seg_ref (INT32 sym_idx ) 00239 { 00240 STB_pkt *p ; 00241 00242 p = cast_to_STB(sym_idx); 00243 DevAssert((p->form == is_ST),("Odd seg ref")); 00244 00245 ST * st = cast_to_ST(p->item); 00246 DevAssert((st),("null st")); 00247 00248 cwh_stk_push(st,ST_item) ; 00249 } 00250 00251 /*=============================================== 00252 * 00253 * fei_namelist_ref 00254 * 00255 * Push a reference to a namelist item (an ST) 00256 * on the expression stack. 00257 * 00258 *=============================================== 00259 */ 00260 void 00261 fei_namelist_ref (INTPTR sym_idx ) 00262 { 00263 fei_object_ref(sym_idx, 0, 0); 00264 } 00265 00266 /*=============================================== 00267 * 00268 * fei_member_ref 00269 * 00270 * Push a reference to an derived type 00271 * component on the expression stack. The 00272 * object (variable) will be TOS, or under other 00273 * FLD_items. 00274 * 00275 *=============================================== 00276 */ 00277 extern void 00278 fei_member_ref (INT32 sym_idx ) 00279 { 00280 00281 cwh_stk_push(cast_to_void(sym_idx),FLD_item) ; 00282 } 00283 00284 /*=============================================== 00285 * 00286 * fei_constant 00287 * 00288 * Push a reference to a constant on the 00289 * expression stack. 00290 * 00291 * If it's an Arith_con, then the value is passed 00292 * just create the ST, push a WN on the stack and 00293 * pass back the WN for later use. If it's an 00294 * integral type, there couldn't be an ST, so a 00295 * WN was created instead. The result will be in 00296 * a packet. 00297 * 00298 * For a string(pattern) const we push the size 00299 * too and make it into a STR_item. PCONST_items 00300 * are bit strings used for initialization, mostly. 00301 * Just push those. 00302 * 00303 *=============================================== 00304 */ 00305 extern INTPTR 00306 fei_constant ( TYPE type, 00307 INT32 Class, 00308 char *start, 00309 INT64 bitsize ) 00310 00311 { 00312 WN * wn ; 00313 WN * wc ; 00314 TY_IDX ty ; 00315 INTPTR cn ; 00316 ST *st; 00317 STB_pkt *p ; 00318 00319 switch ((CONSTANT_CLASS)Class) { 00320 case Arith_Const: 00321 00322 cn = fei_arith_con(type,(SLONG *)start) ; 00323 p = cast_to_STB(cn); 00324 00325 if (p->form == is_WN) 00326 wn = cast_to_WN(p->item); 00327 else 00328 wn = cwh_stab_const(cast_to_ST(p->item)); 00329 00330 wc = WN_COPY_Tree(wn); 00331 wn = WN_COPY_Tree(wn); 00332 ty = cast_to_TY(t_TY(type)); 00333 cwh_stk_push_typed(cast_to_void(wn),WN_item,ty) ; 00334 p = cwh_stab_packet_typed(wc,is_WN,ty); 00335 00336 break; 00337 00338 case Pattern_Const: 00339 00340 cn = fei_pattern_con(type,start,bitsize); 00341 00342 if (type.basic_type == Char_Fortran) { 00343 00344 st = (ST *) cast_to_void(cn); 00345 wn = WN_CreateIntconst (OPC_U4INTCONST,TY_size(ST_type(st))); 00346 cwh_stk_push_STR(wn,st,ST_type(st),ST_item); 00347 p = cwh_stab_packet(cast_to_void(cn),is_SCONST); 00348 00349 } else { 00350 cwh_stk_push(cast_to_void(cn),PCONST_item); 00351 p = cwh_stab_packet(cast_to_void(cn),is_PCONST); 00352 } 00353 00354 break; 00355 00356 default: 00357 DevAssert((0), ("Unimplemented constant")); 00358 break ; 00359 } 00360 00361 return(cast_to_int(p)); 00362 } 00363 00364 /*=============================================== 00365 * 00366 * fei_push_arith_con 00367 * 00368 * Push a reference to a constant on the 00369 * expression stack. Copy the WN passed in. 00370 * for logical constants, we have have a TY. 00371 * 00372 *=============================================== 00373 */ 00374 extern void 00375 fei_push_arith_con ( INTPTR cdx ) 00376 { 00377 WN * wn ; 00378 TY_IDX ty ; 00379 STB_pkt *p; 00380 00381 p = cast_to_STB(cdx); 00382 wn = WN_COPY_Tree((WN *) p->item); 00383 ty = p->ty; 00384 00385 if (ty != 0) 00386 cwh_stk_push_typed(cast_to_void(wn),WN_item,ty) ; 00387 else 00388 cwh_stk_push(cast_to_void(wn),WN_item) ; 00389 } 00390 00391 /*=============================================== 00392 * 00393 * fei_push_pattern_con 00394 * 00395 * Push a reference to a string or aggregate 00396 * expression stack. Make the ST passed into 00397 * STR_item or an ST reference. 00398 * 00399 *=============================================== 00400 */ 00401 extern void 00402 fei_push_pattern_con ( INTPTR cdx ) 00403 { 00404 ST *st; 00405 TY_IDX ty; 00406 WN *wn; 00407 STB_pkt *p; 00408 00409 p = cast_to_STB(cdx); 00410 00411 /* called with the ST of a pattern constant */ 00412 st = (ST *) p->item; 00413 00414 if (p->form == is_SCONST) { 00415 ty = ST_type(st); 00416 wn = WN_CreateIntconst (OPC_U4INTCONST,TY_size(ty)); 00417 cwh_stk_push_STR(wn,st,ty,ST_item); 00418 00419 } else { 00420 cwh_stk_push(st,PCONST_item); 00421 } 00422 } 00423 /*=============================================== 00424 * 00425 * fei_pstore 00426 * 00427 * Generate a store. The rhs will be on 00428 * top of the stack, and the lhs symbol 00429 * ST or address WN will be below. 00430 * 00431 * On the lhs we add an OPC_ARRAYEXP to 00432 * describe the iterations, if its an 00433 * array section address 00434 * 00435 * Sometimes a NULL WN is on top because WHIRL 00436 * wants (say) an intrinsic call, or a store 00437 * has already been done. The FE doesn't know 00438 * so fei_store is called & the stack cleared. 00439 * 00440 *=============================================== 00441 */ 00442 /*ARGSUSED*/ 00443 extern void 00444 fei_pstore ( TYPE result_type ) 00445 { 00446 WN * rhs ; 00447 WN * wn ; 00448 ST * st ; 00449 ST * rhs_st; 00450 TY_IDX ty; 00451 TY_IDX ts; 00452 00453 FLD_det det ; 00454 00455 if (cwh_stk_get_class() == STR_item) { 00456 00457 cwh_stmt_character_store(result_type); 00458 00459 } else if (cwh_stk_get_class() == PCONST_item) { 00460 00461 rhs_st = cwh_stk_pop_PCONST(); 00462 ty = ST_type(rhs_st); 00463 rhs = cwh_addr_address_ST(rhs_st,0); 00464 rhs = cwh_addr_mload(rhs,0,ty,NULL); 00465 wn = cwh_expr_address(f_NONE); 00466 wn = cwh_addr_mstore(wn,0,ty,rhs) ; 00467 cwh_block_append(wn) ; 00468 00469 } else { 00470 00471 rhs = cwh_expr_operand(NULL); 00472 00473 if (rhs == NULL) { 00474 cwh_stk_pop_whatever() ; 00475 return ; 00476 } 00477 00478 switch(cwh_stk_get_class()) { 00479 case WN_item: 00480 case WN_item_whole_array: 00481 ts = cwh_stk_get_TY(); 00482 wn = cwh_expr_address(f_NONE); 00483 wn = F90_Wrap_ARREXP(wn) ; 00484 cwh_addr_pstore_WN(wn,0,ts,rhs); 00485 break ; 00486 00487 case DEREF_item: 00488 ts = cwh_stk_get_TY(); 00489 if (ts) { 00490 /* Get the type of the item stored from the dope vector */ 00491 ts = TY_pointed(FLD_type(TY_fld(Ty_Table[ts]))); 00492 } 00493 wn = cwh_expr_address(f_NONE); 00494 wn = F90_Wrap_ARREXP(wn) ; 00495 cwh_addr_pstore_WN(wn,0,ts,rhs); 00496 break ; 00497 00498 case ST_item: 00499 case ST_item_whole_array: 00500 st = cwh_stk_pop_ST(); 00501 cwh_addr_pstore_ST(st,0,0,rhs); 00502 break ; 00503 00504 case FLD_item: 00505 det = cwh_addr_offset(); 00506 00507 if (cwh_stk_get_class() == ST_item || 00508 cwh_stk_get_class() == ST_item_whole_array) { 00509 00510 st = cwh_stk_pop_ST(); 00511 cwh_addr_pstore_ST(st,det.off,det.type,rhs); 00512 00513 } else { 00514 00515 wn = cwh_stk_pop_WHIRL(); 00516 wn = cwh_expr_bincalc(OPR_ADD,wn,WN_Intconst(Pointer_Mtype,det.off)); 00517 wn = F90_Wrap_ARREXP(wn); 00518 cwh_addr_pstore_WN(wn,0,det.type,rhs); 00519 } 00520 break; 00521 00522 default: 00523 DevAssert((0),("odd store LHS")); 00524 } 00525 } 00526 } 00527 00528 00529 /*=============================================== 00530 * 00531 * fei_store 00532 * 00533 * Generate a store. The rhs will be on 00534 * top of the stack, and the lhs symbol 00535 * ST or address WN will be below. 00536 * 00537 * On the lhs we add an OPC_ARRAYEXP to 00538 * describe the iterations, if its an 00539 * array section address 00540 * 00541 * Sometimes a NULL WN is on top because WHIRL 00542 * wants (say) an intrinsic call, or a store 00543 * has already been done. The FE doesn't know 00544 * so fei_store is called & the stack cleared. 00545 * 00546 *=============================================== 00547 */ 00548 /*ARGSUSED*/ 00549 extern void 00550 fei_store ( TYPE result_type ) 00551 { 00552 WN * rhs ; 00553 WN * wn ; 00554 ST * st ; 00555 ST * rhs_st; 00556 TY_IDX ty; 00557 TY_IDX ts; 00558 WN *wt; 00559 WN * wtl; 00560 WN * wd; 00561 TY_IDX ts1; 00562 TY_IDX ts2; 00563 00564 FLD_det det ; 00565 00566 if (cwh_stk_get_class() == STR_item) { 00567 00568 cwh_stmt_character_store(result_type); 00569 00570 } else if (cwh_stk_get_class() == PCONST_item) { 00571 00572 rhs_st = cwh_stk_pop_PCONST(); 00573 ty = ST_type(rhs_st); 00574 rhs = cwh_addr_address_ST(rhs_st,0); 00575 rhs = cwh_addr_mload(rhs,0,ty,NULL); 00576 wn = cwh_expr_address(f_NONE); 00577 wn = cwh_addr_mstore(wn,0,ty,rhs) ; 00578 cwh_block_append(wn) ; 00579 00580 } else { 00581 00582 rhs = cwh_expr_operand(NULL); 00583 00584 if (rhs == NULL) { 00585 cwh_stk_pop_whatever() ; 00586 return ; 00587 } 00588 00589 //FMZ August 2005 00590 if (WN_operator(rhs)==OPR_STRCTFLD) 00591 rhs = addr_gen_iload_for_strctfld(rhs); 00592 00593 switch(cwh_stk_get_class()) { 00594 case WN_item: 00595 case WN_item_whole_array: 00596 ts = cwh_stk_get_TY(); 00597 wn = cwh_expr_address(f_NONE); 00598 wn = F90_Wrap_ARREXP(wn) ; 00599 cwh_addr_store_WN(wn,0,ts,rhs); 00600 break ; 00601 00602 case STR_item: //June 00603 cwh_stk_pop_STR(); 00604 wtl = cwh_stk_pop_WN(); 00605 ts1 = cwh_stk_get_TY(); 00606 wt = cwh_stk_pop_WN(); 00607 wt = cwh_expr_extract_arrayexp(wt,DELETE_ARRAYEXP_WN); 00608 00609 cwh_stk_pop_STR(); 00610 wtl = cwh_stk_pop_WN(); 00611 ts2 = cwh_stk_get_TY(); 00612 cwh_addr_store_WN(wt,0,ts2,rhs); 00613 break; 00614 00615 00616 case DEREF_item: 00617 ts = cwh_stk_get_TY(); 00618 if (ts) { 00619 /* Get the type of the item stored from the dope vector */ 00620 ts = TY_pointed(FLD_type(TY_fld(Ty_Table[ts]))); 00621 } 00622 wn = cwh_expr_address(f_NONE); 00623 wn = F90_Wrap_ARREXP(wn) ; 00624 cwh_addr_store_WN(wn,0,ts,rhs); 00625 break ; 00626 00627 case ST_item: 00628 case ST_item_whole_array: 00629 st = cwh_stk_pop_ST(); 00630 cwh_addr_store_ST(st,0,0,rhs); 00631 break ; 00632 00633 case FLD_item: 00634 det = cwh_addr_offset(); 00635 00636 if (cwh_stk_get_class() == ST_item || 00637 cwh_stk_get_class() == ST_item_whole_array) { 00638 00639 st = cwh_stk_pop_ST(); 00640 cwh_addr_store_ST(st,det.off,det.type,rhs); 00641 00642 } else { 00643 00644 wn = cwh_stk_pop_WHIRL(); 00645 wn = cwh_expr_bincalc(OPR_ADD,wn,WN_Intconst(Pointer_Mtype,det.off)); 00646 wn = F90_Wrap_ARREXP(wn); 00647 cwh_addr_store_WN(wn,0,det.type,rhs); 00648 } 00649 break; 00650 00651 default: 00652 DevAssert((0),("odd store LHS")); 00653 } 00654 } 00655 } 00656 00657 /*=============================================== 00658 * 00659 * fei_non_conform_store 00660 * 00661 * Used when a 1d a temp is assigned to an nd 00662 * destination or vice-versa. Used in constructors. 00663 * 00664 * The OPC_ARRSECTION of the temp is replaced 00665 * with one which describes the same shape as 00666 * The destination. hen the items are pushd back 00667 * onto the stack and fei_store called. There is 00668 * an assumption(assertion) that the temp is a 00669 * contiguous object. 00670 * 00671 *=============================================== 00672 */ 00673 /*ARGSUSED*/ 00674 extern void 00675 fei_non_conform_store( TYPE result_type ) 00676 { 00677 WN *wd ; 00678 WN *wdl ; 00679 TY_IDX td ; 00680 TY_IDX ts1 ; 00681 TY_IDX ts2 ; 00682 00683 WN *wt ; 00684 WN *wtl ; 00685 TY_IDX tt ; 00686 00687 FLD_HANDLE f1 ; 00688 FLD_HANDLE f2 ; 00689 FLD_det d1 ; 00690 FLD_det d2 ; 00691 00692 switch(cwh_stk_get_class()) { 00693 case STR_item: 00694 cwh_stk_pop_STR(); 00695 wtl = cwh_stk_pop_WN(); 00696 ts1 = cwh_stk_get_TY(); 00697 wt = cwh_stk_pop_WN(); 00698 wt = cwh_expr_extract_arrayexp(wt,DELETE_ARRAYEXP_WN); 00699 00700 cwh_stk_pop_STR(); 00701 wdl = cwh_stk_pop_WN(); 00702 ts2 = cwh_stk_get_TY(); 00703 wd = cwh_stk_pop_WN(); 00704 wd = cwh_expr_extract_arrayexp(wd,DELETE_ARRAYEXP_WN); 00705 00706 cwh_addr_nonc_util(&wt,&wd); 00707 00708 cwh_stk_push_STR(wdl,wd,ts2,WN_item); 00709 cwh_stk_push_STR(wtl,wt,ts1,WN_item); 00710 break; 00711 00712 default: 00713 00714 if (cwh_stk_get_class() == FLD_item) { 00715 d1 = cwh_addr_offset(); 00716 f1 = cwh_types_fld_dummy(d1.off,d1.type); 00717 } 00718 tt = cwh_stk_get_TY(); 00719 wt = cwh_stk_pop_WHIRL(); 00720 00721 if (!tt) { 00722 tt = cwh_types_WN_TY(wt,FALSE); 00723 } 00724 00725 wt = cwh_expr_extract_arrayexp(wt,DELETE_ARRAYEXP_WN); 00726 00727 if (cwh_stk_get_class() == FLD_item) { 00728 d2 = cwh_addr_offset(); 00729 f2 = cwh_types_fld_dummy(d2.off,d2.type); 00730 } 00731 td = cwh_stk_get_TY(); 00732 wd = cwh_stk_pop_WHIRL(); 00733 00734 if (!td) { 00735 td = cwh_types_WN_TY(wd,FALSE); 00736 } 00737 00738 wd = cwh_expr_extract_arrayexp(wd,DELETE_ARRAYEXP_WN); 00739 00740 cwh_addr_nonc_util(&wt,&wd); 00741 00742 cwh_stk_push_typed(wd,WN_item,td); 00743 if (!f2.Is_Null ()) 00744 cwh_stk_push((void *)f2.Idx (),FLD_item); 00745 00746 cwh_stk_push_typed(wt,WN_item,tt); 00747 if (!f1.Is_Null ()) 00748 cwh_stk_push((void *)f1.Idx(),FLD_item); 00749 00750 } 00751 00752 fei_store(result_type); 00753 } 00754 00755 /*=============================================== 00756 * 00757 * cwh_stmt_character_store. 00758 * 00759 * two str items are on the stack. Pop them, 00760 * and look to see if they are single bytes. 00761 * if not, call CASSIGNMENT. If so, get rid 00762 * of the STR items and sizes, then store. 00763 * 00764 * Could expand to two bytes etc, but would 00765 * need padding and dependence checking, so 00766 * better as CASSIGNMENT intrinsic optimization. 00767 * 00768 *=============================================== 00769 */ 00770 static void 00771 cwh_stmt_character_store(TYPE result_type) 00772 { 00773 WN * src; 00774 00775 if (cwh_stk_is_byte_STR(0) && 00776 cwh_stk_is_byte_STR(1)) { 00777 00778 cwh_stk_pop_STR(); 00779 cwh_stk_pop_whatever(); 00780 src = cwh_expr_operand(NULL); 00781 src = cwh_expr_dispose_of_char(src); 00782 00783 cwh_stk_pop_STR(); 00784 cwh_stk_pop_whatever(); 00785 00786 cwh_stk_push(src,WN_item); 00787 fei_store(result_type); 00788 00789 } else { 00790 cwh_stmt_character_icall(INTRN_CASSIGNSTMT); 00791 } 00792 } 00793 00794 /*=============================================== 00795 * 00796 * fei_function_ref 00797 * 00798 * Given an ST of a function, stick it on the stack. 00799 * It will be popped by fei_call. 00800 * 00801 *=============================================== 00802 */ 00803 extern void 00804 fei_function_ref(INTPTR id) 00805 { 00806 STB_pkt *p; 00807 00808 p = cast_to_STB(id) ; 00809 00810 DevAssert((p->form == is_ST),("Fn ST missing")); 00811 DevAssert((p->item != NULL),("NULL fn imp")); 00812 00813 cwh_stk_push(cast_to_ST(p->item), ST_item); 00814 } 00815 00816 /*=============================================== 00817 * 00818 * cwh_stmt_call_helper 00819 * 00820 * Build a call stmt. For a conventional call 00821 * arguments are on the stack, as ADDR_items or 00822 * STR_items, with the ST of the call name beneath 00823 * them. For an intrinsic or library call, there 00824 * may just be a value - so test for WN too. 00825 * OPC_PARMs are wrapped aroudn everything - ref 00826 * parms generally, but value parms around WNs. 00827 * 00828 * If it's a function call, then the result 00829 * PREG is pushed onto the stack to be read 00830 * by fei_store. If the function result is 00831 * complex*32 the address of the result is the 00832 * first argument. Results with similar requirements 00833 * eg: character, derived type > 16 bytes have 00834 * already been transformed into arguments by the FFE. 00835 * 00836 * Character lengths are appended to the list, 00837 * unless a character function result, whn it goes 00838 * into the spot after the address. 00839 * 00840 * This function provides a common interface 00841 * for intrinsic routines and user routines. 00842 * The function returns the call node, although it 00843 * will already be in the tree, so that flags might 00844 * be set on it. 00845 * 00846 * inline_state is set to 0=normal, 1=inline, 2=noinline 00847 * 00848 *=============================================== 00849 */ 00850 #include "ir_reader.h" 00851 extern WN * 00852 cwh_stmt_call_helper(INT32 num_args, TY_IDX ty, INT32 inline_state, INT64 flags) 00853 { 00854 WN * wc ; 00855 WN * call_wn ; 00856 WN * wn ; 00857 WN * wa ; 00858 WN * wt ; 00859 WN ** args; 00860 ST * st ; 00861 ST * rt ; 00862 TY_IDX ta ; 00863 TY_IDX ts ; 00864 TY_IDX tr ; 00865 TY_IDX keepty; 00866 INT32 nargs; 00867 INT32 clen ; 00868 00869 INT32 i,k ; 00870 WN * block; 00871 00872 TYPE_ID rbtype1; 00873 TYPE_ID rbtype2; 00874 OPCODE opc; 00875 00876 BOOL forward_barrier = FALSE; 00877 BOOL backward_barrier = FALSE; 00878 WN * barrier_wn; 00879 WN * len; 00880 INT32 association; 00881 ST * keyword; 00882 INT32 number_of_kwd=0; 00883 00884 #if 0 // eraxxon: allow NULL parameter nodes 00885 INT32 num_null_args = 0; 00886 #endif 00887 00888 /* figure # of args, including character lengths, clear return temp ST */ 00889 #ifdef SOURCE_TO_SOURCE 00890 nargs = num_args + cwh_stk_count_STRs(2*num_args) ; 00891 #else 00892 nargs = num_args + cwh_stk_count_STRs(num_args) ; 00893 #endif 00894 00895 clen = nargs; 00896 rt = NULL; 00897 00898 args = (WN **) malloc(nargs*sizeof(WN *)); 00899 00900 for (k = num_args -1; k >= 0 ; k --) { 00901 00902 switch(cwh_stk_get_class()) { 00903 case STR_item: 00904 cwh_stk_pop_STR(); 00905 wa = cwh_stk_pop_WN(); 00906 wc = WN_COPY_Tree(wa); 00907 args[--clen] = cwh_intrin_wrap_value_parm(wa); 00908 00909 /* the STR_item could be ADDR_item or ST_item beneath */ 00910 if (cwh_stk_get_class()== ADDR_item) 00911 wa = cwh_stk_pop_ADDR(); 00912 else 00913 wa = cwh_expr_address(f_T_PASSED); 00914 00915 args[k] = cwh_intrin_wrap_char_parm(wa,wc); 00916 break ; 00917 00918 case ADDR_item: 00919 ta = cwh_stk_get_TY(); 00920 keepty = ta; 00921 wa = cwh_stk_pop_ADDR(); 00922 args[k] = cwh_intrin_wrap_ref_parm(wa,ta); 00923 if (keepty) { 00924 WN_set_ty(args[k],keepty); 00925 } 00926 break; 00927 00928 case WN_item: 00929 case WN_item_whole_array: 00930 ta = cwh_stk_get_TY(); 00931 keepty = ta; 00932 wa = cwh_stk_pop_WN(); 00933 if (wa) { 00934 if (WNOPR(wa)==OPR_ARRAYEXP || 00935 WNOPR(wa)==OPR_PAREN ) 00936 wa = cwh_intrin_wrap_value_parm(wa); 00937 else wa = cwh_intrin_wrap_ref_parm(wa,ta); 00938 00939 if (keepty) 00940 WN_set_ty(wa,keepty); 00941 } 00942 #if 0 // eraxxon: allow NULL parameter nodes 00943 else { 00944 /* eraxxon: we have been given a null WN as an argument and it 00945 should _not_ be transmitted to a WHIRL CALL. It would seem 00946 that we have been given garbage input, but after stepping 00947 through the code and seeing the above guard, such input 00948 seems to be possible. Therefore, we will need to adjust 00949 the argument count so we do not create a WHIRL call with a 00950 null argument. */ 00951 num_null_args++; 00952 } 00953 #endif 00954 00955 args[k] = wa; 00956 00957 break ; 00958 00959 case FLD_item: 00960 case ST_item: 00961 case ST_item_whole_array: 00962 ta = cwh_stk_get_TY(); 00963 keepty = ta; 00964 wa = cwh_expr_operand(NULL); 00965 wa = cwh_intrin_wrap_ref_parm(wa,ta); 00966 if (keepty) 00967 WN_set_ty(wa,keepty); 00968 args[k] = wa; 00969 break ; 00970 00971 case DEREF_item: /* 11Dec00[sos]: Handle "call sub(%val(apointer))" */ 00972 wa = cwh_stk_pop_DEREF(); 00973 wa = cwh_intrin_wrap_value_parm(wa); 00974 args[k] = wa; 00975 break; 00976 00977 default: 00978 DevAssert((0),("Odd call actual")) ; 00979 } 00980 00981 #ifdef SOURCE_TO_SOURCE 00982 if (args[k]) 00983 args[k]->u3.ty_fields.ty = 0; 00984 00985 switch(cwh_stk_get_class()) { //pop out the keyword item 00986 case WN_item: 00987 cwh_stk_pop_WN(); 00988 break; 00989 00990 case STR_item: 00991 cwh_stk_pop_STR(); 00992 cwh_stk_pop_WN(); /* pop out length of the keyword*/ 00993 keyword = cwh_stk_pop_ST(); 00994 args[k]->u3.ty_fields.ty = ST_st_idx(keyword); 00995 number_of_kwd++; 00996 break ; 00997 00998 default: 00999 DevAssert((0),("Odd call key word")) ; 01000 } 01001 #endif 01002 01003 /* set the dummy-actual arguments association flags */ 01004 association = arg_association_info.top(); 01005 arg_association_info.pop(); 01006 01007 if (args[k]) { 01008 switch (association) { 01009 01010 case PASS_ADDRESS: 01011 WN_Set_Parm_Pass_Address(args[k]); 01012 break; 01013 case PASS_ADDRESS_FROM_DV: 01014 WN_Set_Parm_Pass_Address_From_Dv(args[k]); 01015 break; 01016 case PASS_DV: 01017 WN_Set_Parm_Pass_Dv(args[k]); 01018 break; 01019 case PASS_DV_COPY: 01020 WN_Set_Parm_Pass_Dv_Copy(args[k]); 01021 break; 01022 case COPY_IN: 01023 WN_Set_Parm_Copy_In(args[k]); 01024 break; 01025 case COPY_IN_COPY_OUT: 01026 WN_Set_Parm_Copy_In_Copy_out(args[k]); 01027 break; 01028 case MAKE_DV: 01029 WN_Set_Parm_Make_Dv(args[k]); 01030 break; 01031 case COPY_IN_MAKE_DV: 01032 WN_Set_Parm_Copy_In_Make_Dv(args[k]); 01033 break; 01034 case MAKE_NEW_DV: 01035 WN_Set_Parm_Make_New_Dv(args[k]); 01036 break; 01037 case PASS_SECTION_ADDRESS: 01038 WN_Set_Parm_Pass_Section_Address(args[k]); 01039 break; 01040 case CHECK_CONTIG_FLAG: 01041 WN_Set_Parm_Check_Contig_Flag(args[k]); 01042 break; 01043 default: 01044 break; 01045 } 01046 } 01047 01048 } 01049 01050 if (number_of_kwd) { //move lengths forword 01051 if (nargs > (num_args + number_of_kwd)) 01052 for (k=num_args; k< nargs; k++) 01053 args[k]= args[k + number_of_kwd]; 01054 nargs -= number_of_kwd; 01055 } 01056 01057 #if 0 // eraxxon: allow NULL parameter nodes 01058 /* eraxxon: adjust argument count if we have a NULL WN as an argument */ 01059 if (num_null_args > 0) { 01060 int num_null_args_at_end = 0; 01061 for (int i = num_args - 1; i >= 0; --i) { 01062 if (!args[i]) { 01063 num_null_args_at_end++; 01064 } else { 01065 break; 01066 } 01067 } 01068 01069 /* we only handle trailing null args */ 01070 DevAssert((num_null_args_at_end == num_null_args), 01071 ("Non-trailing NULL args for CALL. Yuck!")); 01072 nargs -= num_null_args; 01073 num_args -= num_null_args; 01074 } 01075 #endif 01076 01077 01078 /* Function returning character? Reorder to get */ 01079 /* length of function result as 2nd argument. */ 01080 /* Function returning struct by value? Delete */ 01081 /* first arg. */ 01082 /* Will not have function's TY, if via proc_imp */ 01083 /* so look at first arg. */ 01084 01085 st = cwh_stk_pop_ST(); 01086 ts = ty ; 01087 tr = ty ; 01088 if (st) { 01089 if (ST_class(st) != CLASS_FUNC) { /* Must be indirect call, so ptr to */ 01090 /* function. Get function type */ 01091 01092 DevAssert((TY_kind(ST_type(st)) == KIND_POINTER && 01093 TY_kind(TY_pointed(ST_type(st))) == KIND_FUNCTION), 01094 ("Odd ST")); 01095 01096 tr = TY_ret_type(TY_pointed(ST_type(st))); 01097 } 01098 01099 # if 0 01100 if (ST_auxst_has_rslt_tmp(st) || cwh_types_is_character(tr)) { 01101 01102 tr = cwh_types_WN_TY(args[0],FALSE); 01103 01104 if (cwh_types_is_character(tr)) { 01105 01106 wt = args[clen]; 01107 01108 for (k = clen ; k > 1 ; k--) 01109 args[k] = args[k-1]; 01110 01111 args[1] = wt; 01112 01113 } else if (STRUCT_BY_VALUE(tr)) { 01114 01115 DevAssert((WNOPR(args[0]) == OPR_PARM),("Odd result")); 01116 wt = WN_kid(args[0],0); 01117 01118 DevAssert((wt),("struct w/o temp")); 01119 DevAssert((WNOPR(wt) == OPR_LDA),("struct w/o ADDR_item")); 01120 01121 rt = WN_st(wt); 01122 ts = tr ; 01123 01124 nargs --; 01125 01126 for (i=0; i < nargs; i++) 01127 args[i] = args[i+1]; 01128 01129 } 01130 } 01131 01132 # endif 01133 01134 01135 /* create call (or indirect call if dummy procedure) */ 01136 01137 if (WHIRL_Return_Info_On) { 01138 01139 RETURN_INFO return_info = Get_Return_Info (ts, Use_Simulated); 01140 01141 if (RETURN_INFO_count(return_info) <= 2 || 01142 WHIRL_Return_Val_On) { 01143 01144 rbtype1 = RETURN_INFO_mtype (return_info, 0); 01145 rbtype2 = RETURN_INFO_mtype (return_info, 1); 01146 } 01147 01148 else 01149 Fail_FmtAssertion ("cwh_stmt_call_helper: more than 2 return registers"); 01150 } 01151 01152 else 01153 Get_Return_Mtypes(ts, Use_Simulated, &rbtype1,&rbtype2); 01154 01155 01156 if (ST_sclass(st) != SCLASS_FORMAL) { 01157 if (TY_kind(ts)==KIND_ARRAY) 01158 opc = OPCODE_make_op(OPR_CALL,TY_mtype(TY_etype(ts)),MTYPE_V); 01159 else 01160 opc = OPCODE_make_op(OPR_CALL,TY_mtype(ts),MTYPE_V); 01161 wn = WN_Create(opc,nargs); 01162 WN_st_idx(wn) = ST_st_idx(st); 01163 01164 /* if the name of the routine is one of mp_setlock mp_unsetlock 01165 or mp_barrier then set barrier flags (PV 485782) */ 01166 01167 if (cwh_stmt_sgi_mp_flag) { 01168 if (rbtype1==MTYPE_V && ST_name(st) && 01169 ST_name(st)[0]=='m' && ST_name(st)[1]=='p') { 01170 if (!strcmp(&(ST_name(st)[2]),"_setlock_")) { 01171 backward_barrier = TRUE; 01172 } else if (!strcmp(&(ST_name(st)[2]),"_unsetlock_")) { 01173 forward_barrier = TRUE; 01174 } else if (!strcmp(&(ST_name(st)[2]),"_barrier_")) { 01175 forward_barrier = TRUE; 01176 backward_barrier = TRUE; 01177 } 01178 } 01179 } 01180 01181 } else { 01182 01183 opc = OPCODE_make_op (OPR_ICALL,TY_mtype(ts),MTYPE_V); 01184 wn = WN_Create(opc,nargs+1); 01185 WN_set_ty(wn,TY_pointed(ST_type(st))); 01186 WN_kid(wn,nargs) = cwh_addr_load_ST(st,0,ST_type(st)); 01187 } 01188 01189 if (forward_barrier) { 01190 barrier_wn=WN_CreateBarrier ( TRUE, 0 ); 01191 cwh_block_append(barrier_wn); 01192 } 01193 01194 01195 WN_Set_Call_Default_Flags(wn); 01196 WN_Set_Call_Fortran_Pointer_Rule(wn); 01197 01198 if (FE_Call_Never_Return && 01199 test_flag(flags, FEI_CALL_DOES_NOT_RETURN)) { 01200 WN_Set_Call_Never_Return(wn); 01201 } 01202 01203 if (inline_state == 1) { 01204 /* inline */ 01205 WN_Set_Call_Inline(wn); 01206 fe_invoke_inliner = TRUE; 01207 } else if (inline_state == 2) { 01208 /* no inline */ 01209 WN_Set_Call_Dont_Inline(wn); 01210 } 01211 01212 call_wn = wn; 01213 01214 for (i=0; i < nargs; i++) { 01215 WN_kid(wn,i) = args[i]; 01216 } 01217 01218 free(args); 01219 01220 01221 /* Function result - for elementals (with array arguments) whose */ 01222 /* scalar lowering returns values in registers, a statement level */ 01223 /* call is no good, because the f90 lowerer wants to see a store */ 01224 /* into an array-valued temp. So a COMMA node holds the pregs of */ 01225 /* the return and the call block */ 01226 01227 # if 0 01228 01229 if ((ST_auxst_is_elemental(st)) && (TY_mtype(ts) != MTYPE_V)) { 01230 01231 /* ELEMENTAL functions. Build a COMMA node */ 01232 01233 block = cwh_block_new_and_current(); 01234 cwh_block_append(wn); 01235 block = cwh_block_exchange_current(block); 01236 01237 wn = cwh_stmt_return_scalar(rt,NULL,ts,FALSE); 01238 opc = cwh_make_typed_opcode(OPR_COMMA,rbtype1,MTYPE_V); 01239 wn = WN_CreateComma(opc,block,wn); 01240 cwh_stk_push_typed(wn,WN_item,ty); 01241 01242 } else { 01243 # endif 01244 01245 /* put ARRAYEXPs underneath the parm nodes of elementals */ 01246 01247 if (ST_auxst_is_elemental(st) ) { 01248 01249 for (k = 0; k < nargs; k ++) { 01250 WN_kid0(WN_kid(wn,k)) = F90_Wrap_ARREXP(WN_kid0(WN_kid(wn,k))); 01251 01252 } 01253 } 01254 01255 if (TY_mtype(ts) == MTYPE_V) 01256 cwh_block_append(wn); 01257 01258 /* scalar (in registers) function result? */ 01259 /* Push read of pregs on stack, unless struct */ 01260 /* by value when read of temp.. */ 01261 01262 if (TY_mtype(ts) != MTYPE_V) { 01263 if (!cwh_types_is_character(ts)) 01264 cwh_stk_push(wn,WN_item); 01265 else { 01266 len = WN_CreateIntconst(OPC_U4INTCONST,TY_size(ts)); 01267 cwh_stk_push_STR(len,wn,ts,WN_item); 01268 } 01269 } 01270 // } 01271 01272 if (backward_barrier) { 01273 barrier_wn=WN_CreateBarrier ( FALSE, 0 ); 01274 cwh_block_append(barrier_wn); 01275 } 01276 01277 return (call_wn); 01278 } else 01279 return(NULL); 01280 } 01281 01282 /*=============================================== 01283 * 01284 * fei_call 01285 * 01286 * Build a call stmt. For a conventional call 01287 * arguments are on the stack, as ADDR_items or 01288 * STR_items, with the ST of the call name beneath 01289 * them. For an intrinsic or library call, a WN may 01290 * be passed by value. 01291 * 01292 * OPC_PARMs are wrapped around everything - ref 01293 * parms generally, but value parms around WNs. 01294 * 01295 * see cwh_stmt_call_helper. 01296 * 01297 *=============================================== 01298 */ 01299 /*ARGSUSED*/ 01300 extern void 01301 fei_call(INT32 num_args, 01302 TYPE result_type, 01303 INT32 call_type, 01304 INT32 alt_return_flag, 01305 INT32 inline_setting, 01306 INT64 flags) 01307 01308 { 01309 TY_IDX ty; 01310 ty = cast_to_TY(t_TY(result_type)); 01311 (void) cwh_stmt_call_helper(num_args,ty,inline_setting,flags); 01312 } 01313 01314 /*=============================================== 01315 * 01316 * fei_arg_addr 01317 * 01318 * Build an address and push it back on 01319 * the stack. These were PARM nodes, but 01320 * ALOCs were required for some other items 01321 * so PARMS are deferred to fei_call. 01322 * 01323 * For FLD items we need to save the FLD type, 01324 * so find out the TY, address the FLD, then 01325 * push a typed ADDR_item on the stack, so later 01326 * fei_call (say) can put the correct TY in a PARM. 01327 * 01328 *=============================================== 01329 */ 01330 /*ARGSUSED*/ 01331 extern void 01332 fei_arg_addr(TYPE type) 01333 { 01334 WN * wn ; 01335 WN * wa ; 01336 TY_IDX ty ; 01337 TY_IDX ts ; 01338 FLD_HANDLE fld; 01339 FLD_det det; 01340 01341 switch(cwh_stk_get_class()) { 01342 case STR_item: 01343 cwh_stk_pop_STR(); 01344 wn = cwh_stk_pop_WN(); 01345 ts = cwh_stk_get_TY(); 01346 wa = cwh_expr_address(f_T_PASSED); 01347 cwh_stk_push_STR(wn,wa,ts,ADDR_item); 01348 break; 01349 01350 case FLD_item: 01351 det = cwh_addr_offset(); 01352 fld = cwh_types_fld_dummy(det.off,det.type); 01353 cwh_stk_push((void *)fld.Idx (),FLD_item); 01354 wa = cwh_expr_address(f_T_PASSED); 01355 cwh_stk_push_typed(wa,ADDR_item, cwh_types_make_pointer_type(det.type, FALSE)); 01356 break; 01357 01358 case WN_item_whole_array: 01359 wa = cwh_expr_address(f_T_PASSED); 01360 DevAssert ((WNOPR(wa) == OPR_ARRAY), ("Whole array isnt an ARRAY")); 01361 wa = WN_kid0(wa); /* the base */ 01362 ty = cwh_types_WN_TY(wa,FALSE); 01363 ty = cwh_types_make_pointer_type(ty, FALSE); 01364 cwh_stk_push_typed(wa,ADDR_item,ty); 01365 break; 01366 01367 default: 01368 wa = cwh_expr_address(f_T_PASSED); 01369 if (WNOPR(wa) == OPR_ARRAY) { 01370 ty = cwh_types_WN_TY(wa,FALSE); 01371 ty = cwh_types_array_TY(ty); 01372 ty = cwh_types_scalar_TY(ty); 01373 ty = cwh_types_make_pointer_type(ty, FALSE); 01374 cwh_stk_push_typed(wa,ADDR_item,ty); 01375 01376 } else 01377 cwh_stk_push(wa,ADDR_item); 01378 break; 01379 } 01380 } 01381 01382 01383 /*=============================================== 01384 * 01385 * fei_fcd 01386 * 01387 * A reference via a cray character pointer is 01388 * on the stack. Make it into a STR_item and 01389 * & push it. The address should look as though 01390 * it came from fei_arg_addr ie: an ADDR_item. 01391 * 01392 *=============================================== 01393 */ 01394 /*ARGSUSED*/ 01395 void 01396 fei_fcd(TYPE result_type) 01397 { 01398 WN *wn ; 01399 WN *ad ; 01400 WN *ln ; 01401 TY_IDX ts ; 01402 01403 ts = cwh_stk_get_TY(); 01404 ad = cwh_stk_pop_WHIRL(); 01405 ln = cwh_stk_pop_WHIRL(); 01406 01407 if (WNOPR(ad) == OPR_INTCONST) { 01408 01409 wn = WN_Intconst(Pointer_Mtype,WN_const_val(ad)); 01410 01411 WN_DELETE_Tree(ad); 01412 ad = wn; 01413 01414 } 01415 if (ts == 0) 01416 ts = cwh_types_WN_TY(wn,FALSE); 01417 01418 cwh_stk_push_STR(ln,ad,ts,ADDR_item); 01419 01420 } 01421 /*=============================================== 01422 * 01423 * fei_addr_con 01424 * 01425 * A constant as an actual argument. Find or 01426 * make (integers) the constant's ST, make an 01427 * address & push the address. 01428 * 01429 *=============================================== 01430 */ 01431 extern void 01432 fei_addr_con(TYPE type) 01433 { 01434 WN * wn; 01435 WN * wt; 01436 ST * st; 01437 TY_IDX ty; 01438 01439 TCON tc ; 01440 TYPE_ID bt ; 01441 01442 01443 switch (cwh_stk_get_class()) { 01444 case STR_item: 01445 cwh_stk_pop_STR(); 01446 wn = cwh_stk_pop_WN(); 01447 ty = cwh_stk_get_TY(); 01448 wt = cwh_expr_address(f_T_PASSED); 01449 cwh_stk_push_STR(wn,wt,ty,ADDR_item); 01450 break; 01451 01452 default: 01453 ty = cwh_stk_get_TY(); 01454 wn = cwh_stk_pop_WN(); 01455 01456 if (WNOPR(wn) == OPR_INTCONST) { 01457 01458 if (ty == 0) { 01459 bt = WNRTY(wn); 01460 } else { 01461 bt = TY_mtype(ty); 01462 } 01463 tc = Host_To_Targ (bt,WN_const_val(wn)); 01464 st = New_Const_Sym(Enter_tcon (tc), Be_Type_Tbl(bt)); 01465 01466 } else 01467 st = WN_st(wn); 01468 01469 wt = cwh_addr_address_ST(st,0); 01470 01471 if (ty ==0) 01472 cwh_stk_push(wt,ADDR_item); 01473 else 01474 cwh_stk_push_typed(wt,ADDR_item,ty); 01475 } 01476 } 01477 01478 /*=============================================== 01479 * 01480 * fei_entry_pt 01481 * 01482 * Generate an OPC_ALTENTRY and tack the dummy 01483 * argument list on. Idx is the ST of the entry. 01484 * 01485 *=============================================== 01486 */ 01487 extern void 01488 fei_entry_pt(INTPTR idx) 01489 { 01490 ST *st ; 01491 ST **ap ; 01492 WN *wn ; 01493 STB_pkt *p ; 01494 01495 INT16 nkids,i ; 01496 01497 p = cast_to_STB(idx); 01498 st = cast_to_ST(p->item); 01499 01500 nkids = cwh_auxst_num_dummies(st); 01501 ap = cwh_auxst_arglist(st); 01502 01503 wn = WN_Create (OPC_ALTENTRY, nkids); 01504 WN_st_idx(wn) = ST_st_idx(st); 01505 01506 for (i = 0 ; i < nkids ; i ++) 01507 WN_kid(wn,i) = WN_CreateIdname ( 0, *ap++); 01508 01509 cwh_block_append(wn) ; 01510 (void) cwh_block_toggle_debug(FALSE) ; 01511 } 01512 01513 /*=============================================== 01514 * 01515 * fei_goto 01516 * 01517 * Generate a GOTO to the label whose ST is provided. 01518 * 01519 *=============================================== 01520 */ 01521 extern void 01522 fei_goto(INT32 lbl_idx) 01523 { 01524 LABEL_IDX lb ; 01525 01526 lb = cast_to_LB(lbl_idx); 01527 cwh_stmt_goto(lb); 01528 } 01529 01530 /*=============================================== 01531 * 01532 * fei_arith_goto 01533 * 01534 * Handles the Fortran arithmetic goto statement. 01535 * 01536 * The expression used for computing the goto is on 01537 * the stack. 01538 * If all three labels are equal, a single goto is 01539 * generated. If any two labels are equal, the labels 01540 * are combined into two labels. The expression is 01541 * compared against zero and branches are generated 01542 * to the right labels. 01543 * 01544 *=============================================== 01545 */ 01546 01547 extern void 01548 fei_arith_goto(INT32 eq_lbl, 01549 INT32 gt_lbl, 01550 INT32 lt_lbl ) 01551 { 01552 WN *expr; 01553 WN *val1, *val2; 01554 WN *wn; 01555 LABEL_IDX lb ; 01556 TY_IDX ty; 01557 OPCODE opc; 01558 OPERATOR opr; 01559 INT32 true_lbl; 01560 INT32 false_lbl; 01561 01562 01563 if (lt_lbl == eq_lbl && gt_lbl == eq_lbl) { 01564 01565 /* All three labels are the same */ 01566 01567 cwh_stmt_goto(cast_to_LB(eq_lbl)); 01568 expr = cwh_expr_operand(NULL); 01569 01570 } else { 01571 01572 expr = cwh_expr_operand(NULL); 01573 ty = Be_Type_Tbl(WN_rtype(expr)); 01574 01575 if ( WN_operator(expr) == OPR_SUB ) { 01576 val1 = WN_kid0(expr); 01577 val2 = WN_kid1(expr); 01578 } else { 01579 val1 = expr; 01580 if (MTYPE_is_integral(TY_mtype(ty))) { 01581 opc = cwh_make_typed_opcode(OPR_INTCONST, TY_mtype(ty), MTYPE_V); 01582 val2 = WN_CreateIntconst ( opc, 0 ); 01583 } else { 01584 val2 = Make_Zerocon ( TY_mtype(ty) ); 01585 } 01586 } 01587 01588 if (eq_lbl != lt_lbl && 01589 eq_lbl != gt_lbl && 01590 lt_lbl != gt_lbl ) { 01591 /* All three labels are different. 01592 * Nothing much can be done in this case. 01593 */ 01594 lb = cast_to_LB(lt_lbl); 01595 01596 wn = cwh_stmt_truebr(WN_COPY_Tree(val1), WN_COPY_Tree(val2), ty, OPR_LT,lb); 01597 cwh_block_append(wn); 01598 01599 lb = cast_to_LB(gt_lbl); 01600 wn = cwh_stmt_truebr(WN_COPY_Tree(val1), WN_COPY_Tree(val2), ty, OPR_GT,lb); 01601 cwh_block_append(wn); 01602 cwh_stmt_goto(cast_to_LB(eq_lbl)); 01603 01604 01605 } else { 01606 /* Two of the labels are the same. 01607 * Figure out how to combine these two. 01608 */ 01609 if (eq_lbl == lt_lbl) { 01610 opr = OPR_LE; 01611 true_lbl = eq_lbl; 01612 false_lbl = gt_lbl; 01613 01614 } else if (eq_lbl == gt_lbl) { 01615 opr = OPR_GE; 01616 true_lbl = eq_lbl; 01617 false_lbl = lt_lbl; 01618 01619 } else { 01620 opr = OPR_NE; 01621 true_lbl = gt_lbl; 01622 false_lbl = eq_lbl; 01623 } 01624 01625 lb = cast_to_LB(true_lbl); 01626 wn = cwh_stmt_truebr(WN_COPY_Tree(val1), WN_COPY_Tree(val2), ty, opr,lb); 01627 cwh_block_append(wn); 01628 cwh_stmt_goto(cast_to_LB(false_lbl)); 01629 } 01630 } 01631 } 01632 01633 /*=============================================== 01634 * 01635 * fei_label_ref 01636 * 01637 * Places a label on the stack. 01638 * 01639 *=============================================== 01640 */ 01641 extern void 01642 fei_label_ref(INT32 lbl_idx) 01643 { 01644 LABEL_IDX lb; 01645 lb = cast_to_LB(lbl_idx); 01646 cwh_stk_push(cast_to_void(lb),LB_item); 01647 } 01648 01649 /*=============================================== 01650 * 01651 * fei_label_addr 01652 * 01653 * Used with Fortran Assign statement. 01654 * 01655 * Increments the index into the table that has all 01656 * the assigned goto labels. This is only done if the 01657 * label hasn't been seen before, in which case the assign_id 01658 * field in the AUXST will be -1. Creates an INTCONST out 01659 * of this index and pushes it on the stack. This node 01660 * ends up getting stored into the location of the ASSIGN 01661 * var later. 01662 * 01663 *=============================================== 01664 */ 01665 /*ARGSUSED*/ 01666 extern void 01667 fei_label_addr(INT32 lbl_idx) 01668 { 01669 WN *wn; 01670 INT32 *assign_id; 01671 01672 assign_id = cwh_auxst_assign_id(CURRENT_SYMTAB, (LABEL_IDX)lbl_idx); 01673 01674 if (*assign_id == -1) 01675 *assign_id = cwh_assign_label_id++; 01676 01677 wn = WN_CreateIntconst (OPC_I4INTCONST, *assign_id); 01678 cwh_stk_push(wn, WN_item); 01679 } 01680 01681 /*=============================================== 01682 * 01683 * cwh_stmt_computed_goto 01684 * 01685 * Handle the Fortran computed goto statement. 01686 * 01687 * Labels referenced are pushed on the stack via fei_label_ref. 01688 * Below the labels is the expression that controls 01689 * the computed goto. 01690 * If there are more than 6 distinct labels in the list of labels 01691 * the routine just generates a COMPGOTO, otherwise, it converts 01692 * this into the appropriate TRUE and FALSE branches. 01693 * 01694 *=============================================== 01695 */ 01696 01697 static void 01698 cwh_stmt_computed_goto(INT32 num_labels) 01699 { 01700 LABEL_IDX *label_list; 01701 LABEL_IDX default_label_num = 0; 01702 WN *parent_block; 01703 WN *wn; 01704 WN *default_label; 01705 WN *expr; 01706 OPERATOR opr; 01707 LABEL_IDX lb; 01708 LABEL_IDX last_label=0; 01709 INT32 sequences=0; 01710 INT32 count; 01711 INT32 i; 01712 01713 label_list = (LABEL_IDX *) malloc(num_labels*sizeof(LABEL_IDX)); 01714 01715 for(i=num_labels-1; i>=0; i--) { 01716 label_list[i] = cwh_stk_pop_LB(); 01717 if (label_list[i] != last_label) { 01718 sequences++; 01719 last_label = label_list[i]; 01720 } 01721 } 01722 01723 expr = cwh_expr_operand(NULL); 01724 01725 if (num_labels == 1) { 01726 01727 cwh_stmt_append_truebr(WN_COPY_Tree(expr),1, OPR_EQ, label_list[0]); 01728 01729 } else if ( sequences == 1 && num_labels >= 2) { 01730 01731 (void) New_LABEL (CURRENT_SYMTAB, default_label_num); 01732 01733 cwh_stmt_append_truebr(WN_COPY_Tree(expr),1, OPR_LT,default_label_num); 01734 cwh_stmt_append_truebr(WN_COPY_Tree(expr),num_labels, OPR_LE,label_list[0]); 01735 01736 } else if ( num_labels <= COMPGOTO_IF_ELSE) { 01737 01738 for(i=0; i<num_labels; i++) { 01739 cwh_stmt_append_truebr(WN_COPY_Tree(expr),i+1,OPR_EQ,label_list[i]); 01740 } 01741 01742 } else if (sequences <= COMPGOTO_IF_ELSE) { 01743 01744 (void) New_LABEL (CURRENT_SYMTAB, default_label_num); 01745 cwh_stmt_append_truebr(WN_COPY_Tree(expr),1,OPR_LT,default_label_num); 01746 01747 last_label = label_list[0]; 01748 count = 0; 01749 01750 for(i=0; i<num_labels; i++) { 01751 if (label_list[i] == last_label) { 01752 count++; 01753 } else { 01754 lb = last_label; 01755 if (count == 1) 01756 opr = OPR_EQ; 01757 else 01758 opr = OPR_LE; 01759 cwh_stmt_append_truebr(WN_COPY_Tree(expr),i,opr,lb); 01760 count = 1; 01761 last_label = label_list[i]; 01762 } 01763 } 01764 01765 if (count == 1) 01766 opr = OPR_EQ; 01767 else 01768 opr = OPR_LE; 01769 01770 cwh_stmt_append_truebr(WN_COPY_Tree(expr),num_labels,opr,last_label); 01771 01772 } else { 01773 01774 parent_block = cwh_block_new_and_current(); 01775 (void) New_LABEL (CURRENT_SYMTAB, default_label_num); 01776 cwh_stmt_goto(default_label_num); 01777 01778 for(i=0; i<num_labels; i++) { 01779 cwh_stmt_goto(label_list[i]); 01780 } 01781 01782 default_label = WN_CreateGoto (default_label_num); 01783 wn = WN_CreateCompgoto (num_labels+1, expr, cwh_block_current(), default_label, 0); 01784 cwh_block_set_current(parent_block); 01785 cwh_block_append(wn); 01786 01787 } 01788 01789 if (default_label_num) { 01790 wn = WN_CreateLabel(default_label_num, 0,NULL); 01791 cwh_block_append(wn); 01792 } 01793 } 01794 01795 /*=============================================== 01796 * 01797 * cwh_stmt_assigned_goto 01798 * 01799 * Handle the Fortran Assigned goto statement. 01800 * All the labels that have appeared in an ASSIGN 01801 * statement are on the stack in the order they appeared 01802 * in the source. The VAR that controls the assigned 01803 * goto is below those labels. The labels are popped and stored 01804 * into the array cwh_assign_label_array. VAR at this point has 01805 * a value (from fei_label_addr) that can be used to index the 01806 * array cwh_assign_label_array to get the corresponding label. 01807 * 01808 *=============================================== 01809 */ 01810 01811 static void 01812 cwh_stmt_assigned_goto(INT32 num_labels) 01813 { 01814 INT32 i; 01815 LABEL_IDX default_label_num = 0; 01816 WN *expr; 01817 WN *parent_block; 01818 WN *wn; 01819 WN *default_label; 01820 LABEL_IDX lb; 01821 LABEL_IDX *cwh_assign_label_array=NULL; 01822 01823 cwh_assign_label_array = (LABEL_IDX *) malloc (sizeof(LABEL_IDX *) * num_labels); 01824 01825 for(i=0; i<num_labels; i++) 01826 cwh_assign_label_array[i] = cwh_stk_pop_LB(); 01827 01828 expr = cwh_expr_operand(NULL); 01829 01830 if (num_labels <= COMPGOTO_IF_ELSE) { 01831 01832 for(i=0; i<num_labels; i++ ) { 01833 lb = cwh_assign_label_array [i]; 01834 cwh_stmt_append_truebr(WN_COPY_Tree(expr),i,OPR_EQ,lb); 01835 } 01836 01837 } else { 01838 01839 parent_block = cwh_block_new_and_current(); 01840 (void) New_LABEL (CURRENT_SYMTAB, default_label_num); 01841 default_label = WN_CreateGoto (default_label_num); 01842 01843 for(i=0; i<num_labels; i++ ) { 01844 cwh_stmt_goto(cwh_assign_label_array [i]); 01845 } 01846 01847 wn = WN_CreateCompgoto (num_labels, expr, cwh_block_current(), default_label, 0); 01848 cwh_block_set_current(parent_block); 01849 cwh_block_append(wn); 01850 wn = WN_CreateLabel(default_label_num, 0,NULL); 01851 cwh_block_append(wn); 01852 } 01853 } 01854 01855 01856 /*=============================================== 01857 * 01858 * cwh_stmt_truebr 01859 * 01860 * Utility to generate a OPC_TRUEBR given an 01861 * expression, val, label and operator. Does 01862 * not append the WN, but returns it. 01863 * 01864 *=============================================== 01865 */ 01866 static WN * 01867 cwh_stmt_truebr(WN *expr, WN *val, TY_IDX ty, OPERATOR opr, INT32 label_no) 01868 { 01869 WN * wn; 01870 WN * test; 01871 01872 OPCODE opc; 01873 01874 opc = cwh_make_typed_opcode(opr, MTYPE_I4, Mtype_comparison(TY_mtype(ty))); 01875 test = WN_CreateExp2 ( opc, expr, val); 01876 wn = WN_CreateTruebr (label_no, test ); 01877 01878 return wn; 01879 } 01880 01881 /*=============================================== 01882 * 01883 * cwh_stmt_append_truebr 01884 * 01885 * Utility to generate a OPC_TRUEBR given an 01886 * integer constant, label and operator & append it 01887 * to the current block. 01888 * 01889 *=============================================== 01890 */ 01891 static void 01892 cwh_stmt_append_truebr(WN *expr, INT64 con, OPERATOR opr, INT32 label_no) 01893 { 01894 WN * wn; 01895 WN * val; 01896 TY_IDX ty; 01897 OPCODE opc; 01898 01899 ty = Be_Type_Tbl(WN_rtype(expr)); 01900 opc = cwh_make_typed_opcode(OPR_INTCONST, TY_mtype(ty), MTYPE_V); 01901 01902 val = WN_CreateIntconst (opc,con); 01903 wn = cwh_stmt_truebr(expr,val,ty,opr,label_no) ; 01904 cwh_block_append(wn); 01905 } 01906 01907 /*=============================================== 01908 * 01909 * cwh_stmt_falsebr 01910 * 01911 * Utility to generate a OPC_FALSEBR given an 01912 * expression, val, label and operator.Does 01913 * not append the WN, but returns it. 01914 * 01915 *=============================================== 01916 */ 01917 static WN * 01918 cwh_stmt_falsebr(WN *expr, WN *val, TY_IDX ty, OPERATOR opr, INT32 label_no) 01919 { 01920 WN * wn; 01921 WN * test; 01922 01923 OPCODE opc; 01924 01925 opc = cwh_make_typed_opcode(opr, MTYPE_I4, Mtype_comparison(TY_mtype(ty))); 01926 test = WN_CreateExp2 ( opc, expr, val); 01927 wn = WN_CreateFalsebr (label_no, test ); 01928 01929 return wn; 01930 } 01931 01932 /*=============================================== 01933 * 01934 * cwh_stmt_goto 01935 * 01936 * Utility to generate an OPC_GOTO the label. 01937 * Appends it to the current block. 01938 * 01939 *=============================================== 01940 */ 01941 static void 01942 cwh_stmt_goto(LABEL_IDX label) 01943 { 01944 WN * wn; 01945 wn = WN_CreateGoto(label); 01946 cwh_block_append(wn) ; 01947 } 01948 01949 /*=============================================== 01950 * 01951 * fei_indirect_goto 01952 * 01953 * Handle computed goto and assigned goto. A zero 01954 * value for assign_goto_flag indicates that this 01955 * is a call for computed goto; a non-zero value 01956 * indicates that the call is for an assigned goto. 01957 * 01958 *=============================================== 01959 */ 01960 extern void 01961 fei_indirect_goto(INT32 num_labels, 01962 INT32 assign_goto_flag ) 01963 { 01964 01965 if (assign_goto_flag == 0) 01966 cwh_stmt_computed_goto(num_labels); 01967 else 01968 cwh_stmt_assigned_goto(num_labels); 01969 } 01970 01971 01972 /*=============================================== 01973 * 01974 * cwh_stmt_select_char 01975 * 01976 * Handles the fortran 90 select statement when the controlling expression 01977 * is a character expression. The expression controlling the select is on 01978 * top of the stack. The two args to the routine are: 01979 * 1. Number of SELECT cases. 01980 * 2. Symbol table index for default label. 01981 * 01982 * The routine just builds a whirl node that contains the goto to the 01983 * default label. 'last_node' remembers the position where the last whirl 01984 * node was appended in the current block. This position is used to emit 01985 * the IF's to handle the individual cases of the SELECT statement later. 01986 * 01987 * Before exit, the routine will push the following items back on 01988 * the stack: 01989 * 1. num_cases 01990 * 2. Whirl node that conatins the goto to the default label 01991 * 3. The select expression 01992 * 4. last_node 01993 * 01994 *=============================================== 01995 01996 */ 01997 static void 01998 cwh_stmt_select_char(INT32 num_cases, 01999 INT32 default_label_idx ) 02000 { 02001 WN *wn1; 02002 W_node expr[2]; 02003 WN *default_label; 02004 WN *last_node; 02005 LABEL_IDX lb; 02006 02007 cwh_expr_str_operand(expr); 02008 02009 if (num_cases > 0) { 02010 02011 last_node = WN_last(cwh_block_current()); 02012 02013 lb = cast_to_LB(default_label_idx); 02014 default_label = WN_CreateGoto (lb); 02015 02016 /* Now push num_cases, default_label, expr and last_node back on the stack */ 02017 02018 wn1 = WN_CreateIntconst(OPC_I4INTCONST, num_cases); 02019 cwh_stk_push(wn1, WN_item); 02020 cwh_stk_push(default_label, WN_item); 02021 cwh_stk_push_STR(W_wn(expr[0]), W_wn(expr[1]),W_ty(expr[1]), WN_item); 02022 cwh_stk_push(last_node, WN_item); 02023 02024 } else { /* empty select */ 02025 02026 WN_DELETE_Tree(W_wn(expr[0])); 02027 WN_DELETE_Tree(W_wn(expr[1])); 02028 02029 } 02030 } 02031 02032 /*=============================================== 02033 * 02034 * cwh_stmt_select_case_char 02035 * 02036 * Handle individual cases in a select statement controlled by a character 02037 * expression. On entry, the stack holds the following items, starting from 02038 * the top: 02039 * 1. high_range if present 02040 * 2. low_range if present 02041 * 3. Label to branch to 02042 * 4. last_node, position within current block where to generate the IF's. 02043 * 5. The select expression 02044 * 6. whirl node containing goto to the default label 02045 * 7. Remaining cases to be handled for this select 02046 * 02047 * The args to the routine are: 02048 * 1. flag to indicate low range present 02049 * 2. flag to indicate high range present 02050 * 3. flag to indicate if this is followed by a case which needs a branch to 02051 * the same label; eg. case (-1, 0), will come as case(-1) and 02052 * case(0) and for case(-1) this flag will be true, because case(0) 02053 * requires a branch to the same label. 02054 * 02055 * The routine copies the expr and the range items back on the stack and calls 02056 * cwh_expr_compare to do a character comparison. Depending on the outcome, 02057 * a branch is generated to the appropriate label. 02058 * 02059 * On exit, the routine is expected to push the following items back on 02060 * the stack, if there are any remaining cases for this SELECT: 02061 * 1. If case_follows is TRUE, push the label back. 02062 * 2. remaining cases 02063 * 3. Whirl node that contains the goto to the default label 02064 * 4. The select expr. 02065 * 5. last_node 02066 * 02067 * 02068 *=============================================== 02069 */ 02070 02071 static void 02072 cwh_stmt_select_case_char(INT32 low_value_pres, 02073 INT32 high_value_pres, 02074 INT32 case_follows) 02075 { 02076 W_node val[2]; 02077 W_node high_val[2]; 02078 W_node expr[2]; 02079 02080 WN *copy[2]; 02081 WN *wn1; 02082 02083 WN *last_node; 02084 WN *default_label; 02085 LABEL_IDX label; 02086 INT32 remaining_cases; 02087 LABEL_IDX new_label_num=0; 02088 OPERATOR opr; 02089 02090 if (low_value_pres && high_value_pres) 02091 cwh_expr_str_operand(high_val); 02092 02093 cwh_expr_str_operand(val); 02094 label = cwh_stk_pop_LB(); 02095 last_node = cwh_expr_operand(NULL); 02096 cwh_expr_str_operand(expr); 02097 default_label = cwh_expr_operand(NULL); 02098 remaining_cases = WN_const_val(cwh_expr_operand(NULL)); 02099 Set_LABEL_KIND(New_LABEL (CURRENT_SYMTAB, new_label_num), LKIND_SELECT_GEN); 02100 02101 if (remaining_cases > 0) { 02102 copy[0] = WN_COPY_Tree(W_wn(expr[0])); 02103 copy[1] = WN_COPY_Tree(W_wn(expr[1])); 02104 } 02105 02106 if (low_value_pres && high_value_pres) { 02107 02108 WN *cpy[2]; 02109 02110 cpy[0] = WN_COPY_Tree(W_wn(expr[0])); 02111 cpy[1] = WN_COPY_Tree(W_wn(expr[1])); 02112 02113 last_node = cwh_stmt_str_falsebr_util(OPR_GE, 02114 expr, 02115 val, 02116 new_label_num, 02117 last_node); 02118 02119 W_wn(expr[0]) = cpy[0]; 02120 W_wn(expr[1]) = cpy[1]; 02121 02122 last_node = cwh_stmt_str_falsebr_util(OPR_LE, 02123 expr, 02124 high_val, 02125 new_label_num, 02126 last_node); 02127 } else { 02128 02129 if (low_value_pres) 02130 opr = OPR_GE; 02131 else if (high_value_pres) 02132 opr = OPR_LE; 02133 else 02134 opr = OPR_EQ; 02135 02136 last_node = cwh_stmt_str_falsebr_util(opr, 02137 expr, 02138 val, 02139 new_label_num, 02140 last_node); 02141 } 02142 02143 wn1 = WN_CreateGoto(label); 02144 cwh_block_insert_after(last_node, wn1); 02145 last_node = wn1; 02146 02147 wn1 = WN_CreateLabel(new_label_num, 0,NULL); 02148 cwh_block_insert_after(last_node, wn1); 02149 last_node = wn1; 02150 02151 remaining_cases = remaining_cases - 1; 02152 02153 if (remaining_cases != 0) { 02154 02155 wn1 = WN_CreateIntconst(OPC_I4INTCONST, remaining_cases); 02156 cwh_stk_push(wn1, WN_item); 02157 cwh_stk_push(default_label, WN_item); 02158 cwh_stk_push_STR(copy[0], copy[1],W_ty(expr[1]),WN_item); 02159 cwh_stk_push(last_node, WN_item); 02160 02161 if (case_follows) 02162 cwh_stk_push(cast_to_void(label), LB_item); 02163 02164 } else { 02165 02166 cwh_block_insert_after(last_node, default_label); 02167 } 02168 } 02169 02170 /*=============================================== 02171 * 02172 * cwh_stmt_select_falsebr_util 02173 * 02174 * Utility function for cwh_stmt_select_case_char. 02175 * Sets up a comparison between the two operands, 02176 * and adds a Falsebr on the result to label. 02177 * 02178 * Doesn't add to current block, but to a deferred 02179 * list of WNs. 02180 * 02181 *=============================================== 02182 */ 02183 static WN * 02184 cwh_stmt_str_falsebr_util(OPERATOR opr, 02185 W_node expr[2], 02186 W_node val[2], 02187 INT32 label, 02188 WN *last_node) 02189 { 02190 WN * test; 02191 WN * wn1 ; 02192 02193 cwh_stk_push_STR(W_wn(expr[0]),W_wn(expr[1]),W_ty(expr[1]),WN_item); 02194 cwh_stk_push_STR(W_wn(val[0]), W_wn(val[1]), W_ty(val[1]), WN_item); 02195 02196 cwh_expr_compare(opr,W_ty(expr[0])); 02197 02198 test = cwh_expr_operand(NULL); 02199 wn1 = WN_CreateFalsebr(label, test); 02200 cwh_block_insert_after(last_node, wn1); 02201 02202 return wn1 ; 02203 } 02204 02205 /*=============================================== 02206 * 02207 * fei_new_select 02208 * 02209 * Handles the fortran 90 select statement. The expression 02210 * controlling the select is on top of the stack. The two args 02211 * to the routine are: 02212 * 1. Number of SELECT cases. 02213 * 2. Symbol table index for default label. 02214 * Case statements such as " case(10:20,31) are split into 02215 * case(10:20) and case(31) when counting # of SELECT case statements. 02216 * 02217 * The select is lowered into an OPC_SWITCH. A block is generated 02218 * where fei_new_select_case later emits the CASEGOTO's. Also, to 02219 * handle ranges, the routine first stores the select expression 02220 * into a a temp and remembers this position in 'last_node', so 02221 * that later in fei_new_select_case it knows where to emit the code 02222 * to handle ranges. 02223 * 02224 * Before exit, the routine will push the following items back on 02225 * the stack: 02226 * 1. num_cases 02227 * 2. Block where the case goto's will be emitted 02228 * 3. Temp which holds the select expression 02229 * 4. last node, position within current block, where the 02230 * store to the temp was done. 02231 * 02232 *=============================================== 02233 */ 02234 02235 void 02236 fei_new_select(INT32 num_cases, 02237 INT32 default_label_idx, 02238 INT32 last_label_idx) 02239 { 02240 WN *parent_block; 02241 WN *wn; 02242 WN *wn1; 02243 WN *expr; 02244 WN *default_label; 02245 WN *last_node; 02246 LABEL_IDX lb, last_lb; 02247 ST *tmp_st; 02248 TY_IDX ty; 02249 02250 if (cwh_stk_get_class() == STR_item) { 02251 02252 cwh_stmt_select_char(num_cases, default_label_idx); 02253 02254 } else { 02255 if (cwh_stk_get_class()==WN_item) { 02256 expr = cwh_stk_pop_WN(); 02257 if (WN_operator(expr) == OPR_STRCTFLD || 02258 (WN_operator(expr) == OPR_ILOAD && 02259 WN_operator(WN_kid0(expr))==OPR_STRCTFLD ) ) 02260 ; 02261 else { 02262 cwh_stk_push(expr,WN_item); 02263 expr = cwh_expr_operand(NULL); 02264 } 02265 } else 02266 expr = cwh_expr_operand(NULL); 02267 02268 if ( num_cases > 0) { 02269 02270 ty = Be_Type_Tbl(WN_rtype(expr)); 02271 tmp_st = cwh_stab_temp_ST(ty, "select_expr"); 02272 cwh_addr_store_ST(tmp_st, 0, ty, WN_COPY_Tree(expr)); 02273 expr = cwh_addr_load_ST(tmp_st, 0, 0); 02274 last_node = WN_last(cwh_block_current()); 02275 02276 /* Create a new block; this is where the CASEGOTO's will be emitted */ 02277 02278 parent_block = cwh_block_new_and_current(); 02279 02280 lb = cast_to_LB(default_label_idx); 02281 last_lb = cast_to_LB(last_label_idx); 02282 default_label = WN_CreateGoto (lb); 02283 if (Label_Table[lb].kind==LKIND_INTERNAL) 02284 Label_Table[lb].kind=LKIND_SELECT_GEN; 02285 if (Label_Table[last_lb].kind==LKIND_INTERNAL) 02286 Label_Table[last_lb].kind=LKIND_SELECT_GEN; 02287 wn = WN_CreateSwitch (num_cases, expr, cwh_block_current(), 02288 default_label, last_lb); 02289 02290 /* Now push num_cases, the block that will contain the */ 02291 /* case goto's, expr and last_node back on the stack */ 02292 02293 wn1 = WN_CreateIntconst(OPC_I4INTCONST, num_cases); 02294 cwh_stk_push(wn1, WN_item); 02295 cwh_stk_push(cwh_block_current(), WN_item); 02296 cwh_stk_push(expr, WN_item); 02297 cwh_stk_push(last_node, WN_item); 02298 02299 /* Now get back to parent block and append the OPC_SWITCH */ 02300 02301 cwh_block_set_current(parent_block); 02302 cwh_block_append(wn); 02303 02304 } else { /* empty select */ 02305 02306 WN_DELETE_Tree(expr); 02307 } 02308 } 02309 } 02310 02311 /*=============================================== 02312 * 02313 * fei_new_select_case 02314 * 02315 * Handle individual cases in a select statement. On entry, 02316 * the stack holds the following items, starting from the top: 02317 * 1. high_range if present 02318 * 2. low_range if present 02319 * 3. Label to branch to 02320 * 4. last_node, position within current block where to emit code to 02321 * handle ranges 02322 * 5. temp that holds the select expression 02323 * 6. Block where the CASEGOTO's will be emitted 02324 * 7. Remaining cases to be handled for this select 02325 * 02326 * The args to the routine are: 02327 * 1. flag to indicate low range present 02328 * 2. flag to indicate high range present 02329 * 3. flag to indicate if this is followed by a case which needs a branch to 02330 * the same label; eg. case (-1, 0), will come as case(-1) and 02331 * case(0) and for case(-1) this flag will be true, because case(0) 02332 * requires a branch to the same label. 02333 * 02334 * The case is converted into a CASEGOTO. If a range is present, a 02335 * comparison is generated between the temp that holds the select expr 02336 * and the range, and if satisfied, the temp is set to to the lower bound 02337 * of the range if present, else it is set to the upper bound. The value 02338 * that the temp is set to is then used in the CASEGOTO. 02339 * 02340 * On exit, the routine is expected to push the following items back on 02341 * the stack, if there are any remaining cases for this SELECT: 02342 * 1. If case_follows is TRUE, push the label back. 02343 * 2. remaining cases 02344 * 3. Block that holds the CASEGOTO's 02345 * 4. temp that holds the select expr. 02346 * 5. last_node, position within current block where the code to handle 02347 * ranges is emitted 02348 * 02349 * 02350 *=============================================== 02351 */ 02352 02353 void 02354 fei_new_select_case(INT64 low_value_pres, 02355 INT64 high_value_pres, 02356 INT32 case_follows) 02357 { 02358 WN *o_val; 02359 WN *high_val; 02360 WN *casegoto_block; 02361 WN *wn; 02362 WN *wn1; 02363 WN *expr; 02364 WN *last_node; 02365 LABEL_IDX label; 02366 TY_IDX ty; 02367 INT32 remaining_cases; 02368 LABEL_IDX new_label_num=0; 02369 02370 if (cwh_stk_get_class() == STR_item) { 02371 02372 cwh_stmt_select_case_char(low_value_pres, high_value_pres, 02373 case_follows); 02374 02375 } else { 02376 02377 if (low_value_pres && high_value_pres) 02378 high_val = cwh_expr_operand(NULL); 02379 02380 o_val = cwh_expr_operand(NULL); 02381 label = cwh_stk_pop_LB(); 02382 02383 last_node = cwh_expr_operand(NULL); 02384 expr = cwh_expr_operand(NULL); 02385 casegoto_block = cwh_expr_operand(NULL); 02386 remaining_cases = WN_const_val(cwh_expr_operand(NULL)); 02387 02388 if (low_value_pres || high_value_pres) { /* if not empty or default case */ 02389 02390 ty = Be_Type_Tbl(WN_rtype(expr)); 02391 Set_LABEL_KIND(New_LABEL (CURRENT_SYMTAB, new_label_num), LKIND_SELECT_GEN); 02392 02393 if (low_value_pres && high_value_pres) { 02394 02395 wn1 = cwh_stmt_falsebr(WN_COPY_Tree(expr), 02396 WN_COPY_Tree(o_val), 02397 ty, 02398 OPR_GE, 02399 new_label_num); 02400 02401 cwh_block_insert_after(last_node, wn1); 02402 last_node = wn1; 02403 02404 wn1 = cwh_stmt_falsebr(WN_COPY_Tree(expr), 02405 WN_COPY_Tree(high_val), 02406 ty, 02407 OPR_LE, 02408 new_label_num); 02409 02410 } else { /* not both, one of high & low */ 02411 02412 OPERATOR opr = OPR_LE; 02413 02414 if (low_value_pres) 02415 opr = OPR_GE; 02416 02417 wn1 = cwh_stmt_falsebr(WN_COPY_Tree(expr), 02418 WN_COPY_Tree(o_val), 02419 ty, 02420 opr, 02421 new_label_num); 02422 02423 } 02424 02425 cwh_block_insert_after(last_node, wn1); 02426 last_node = wn1; 02427 02428 wn1 = cwh_addr_stid (WN_st(expr), 0, ty, WN_COPY_Tree(o_val)); 02429 cwh_block_insert_after(last_node, wn1); 02430 last_node = wn1; 02431 02432 wn1 = WN_CreateLabel(new_label_num, 0,NULL); 02433 cwh_block_insert_after(last_node, wn1); 02434 last_node = wn1; 02435 02436 } 02437 wn = WN_CreateCasegoto(WN_const_val(o_val),label); 02438 if (Label_Table[label].kind==LKIND_INTERNAL) 02439 Label_Table[label].kind=LKIND_SELECT_GEN; 02440 02441 cwh_block_append_given_block(wn,casegoto_block); 02442 02443 remaining_cases = remaining_cases - 1; 02444 02445 if (remaining_cases != 0) { 02446 02447 wn1 = WN_CreateIntconst(OPC_I4INTCONST, remaining_cases); 02448 cwh_stk_push(wn1, WN_item); 02449 cwh_stk_push(casegoto_block, WN_item); 02450 cwh_stk_push(expr, WN_item); 02451 cwh_stk_push(last_node, WN_item); 02452 if (case_follows) 02453 cwh_stk_push(cast_to_void(label), LB_item); 02454 } 02455 02456 } 02457 } 02458 02459 /*=============================================== 02460 * 02461 * fei_label_def_named 02462 * 02463 * Generate an OPC_LABEL at the definition. 02464 * lbl_idx has the ST of the label. 02465 * 02466 * Directives may be set as flags.. 02467 * 02468 *=============================================== 02469 */ 02470 /*ARGSUSED*/ 02471 void fei_label_def_named(INT32 lbl_idx, 02472 INT64 label_flag_word, 02473 INT32 lineno, 02474 INT32 sup_cnt, 02475 INT32 keepme, 02476 INT32 storage_seg, 02477 INT32 safevl, 02478 INT32 unroll_cnt, 02479 char *mark_name, 02480 INT32 pipe_cnt, 02481 INT32 last_argument, 02482 INT32 unused1, 02483 INT32 unused2, 02484 INT32 unused3) 02485 { 02486 WN * wn ; 02487 LABEL_IDX lb ; 02488 WN * expr; 02489 02490 02491 if (!test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_NOT_REFERENCED)) { 02492 lb = cast_to_LB(lbl_idx); 02493 wn = WN_CreateLabel(lb,0,NULL); 02494 02495 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_CASE)) 02496 cwh_stk_push(cast_to_void(lb), LB_item); 02497 02498 cwh_block_append(wn) ; 02499 } 02500 02501 #ifdef _SGI_DIRS 02502 02503 /* handle attached directives */ 02504 02505 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_MAXCPUS)) { 02506 02507 expr = cwh_expr_operand(NULL); 02508 cwh_stmt_add_xpragma(WN_PRAGMA_CRI_MAXCPUS,FALSE,expr); 02509 02510 } 02511 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_SUPPRESS)) { 02512 cwh_directive_barrier_insert(NULL,sup_cnt); 02513 } 02514 02515 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_LOOPCHK)) { 02516 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_PERMUTATION)) { 02517 /* cdir$permutation - DLAI */ 02518 /* use KAP's ASSERT PERMUTATION for now */ 02519 cwh_stmt_add_pragma(WN_PRAGMA_KAP_ASSERT_PERMUTATION); 02520 } 02521 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_IVDEP)) { 02522 cwh_stmt_add_pragma(WN_PRAGMA_IVDEP); 02523 } 02524 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_NOREDUCE)) { 02525 cwh_stmt_add_pragma(WN_PRAGMA_NORECURRENCE); 02526 } 02527 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_SHORTLOOP)) { 02528 cwh_stmt_add_pragma(WN_PRAGMA_CRI_SHORTLOOP,FALSE, NULL,64); 02529 } 02530 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_DO_BL)) { 02531 cwh_stmt_add_pragma(WN_PRAGMA_CRI_BL,FALSE, NULL,1); 02532 } 02533 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_CONCCALLS)) { 02534 cwh_stmt_add_pragma(WN_PRAGMA_KAP_ASSERT_CONCURRENT_CALL); 02535 } 02536 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_NEXTSCALAR)) { 02537 cwh_stmt_add_pragma(WN_PRAGMA_NEXT_SCALAR); 02538 } 02539 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_SHORTLOOP128)) { 02540 cwh_stmt_add_pragma(WN_PRAGMA_CRI_SHORTLOOP,FALSE, NULL,128); 02541 } 02542 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_SELECT_TASK)) { 02543 cwh_stmt_add_pragma(WN_PRAGMA_CRI_PREFERTASK); 02544 } 02545 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_NOTASK)) { 02546 cwh_stmt_add_pragma(WN_PRAGMA_KAP_ASSERT_DO,FALSE, NULL,ASSERT_DO_SERIAL); 02547 } 02548 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_UNROLL)) { 02549 /* An unroll count of 0 is the default unroll, which means no pragme is needed */ 02550 if (unroll_cnt != 0) { 02551 cwh_stmt_add_pragma(WN_PRAGMA_UNROLL,FALSE, NULL,unroll_cnt,-1); 02552 } 02553 } 02554 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_FISSIONABLE)) { 02555 cwh_stmt_add_pragma(WN_PRAGMA_FISSIONABLE); 02556 } 02557 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_FUSABLE)) { 02558 cwh_stmt_add_pragma(WN_PRAGMA_FUSEABLE); 02559 } 02560 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_NOFISSION)) { 02561 cwh_stmt_add_pragma(WN_PRAGMA_NO_FISSION); 02562 } 02563 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_NOFUSION)) { 02564 cwh_stmt_add_pragma(WN_PRAGMA_NO_FUSION); 02565 } 02566 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_NOINTERCHANGE)) { 02567 cwh_stmt_add_pragma(WN_PRAGMA_NO_INTERCHANGE); 02568 } 02569 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_NOBLOCKING)) { 02570 cwh_stmt_add_pragma(WN_PRAGMA_NO_BLOCKING); 02571 } 02572 if (test_flag(label_flag_word, FEI_LABEL_DEF_NAMED_AGGRESSIVEINNERLOOPFISSION)) { 02573 cwh_stmt_add_pragma(WN_PRAGMA_AGGRESSIVE_INNER_LOOP_FISSION); 02574 } 02575 } 02576 #endif /* _SGI_DIRS */ 02577 } 02578 02579 /*=============================================== 02580 * 02581 * fei_brtrue 02582 * 02583 * Generate an OPC_TRUEBR to the label supplied. 02584 * TOS has the condition as T/F. 02585 * 02586 *=============================================== 02587 */ 02588 extern void 02589 fei_brtrue(INT32 lbl_idx) 02590 { 02591 WN *wn; 02592 WN *wc; 02593 LABEL_IDX lb ; 02594 02595 lb = cast_to_LB(lbl_idx); 02596 wc = cwh_expr_operand(NULL); 02597 wn = WN_CreateTruebr(lb,wc); 02598 cwh_block_append(wn) ; 02599 } 02600 02601 /*=============================================== 02602 * 02603 * fei_where 02604 * 02605 * Generate an OPC_WHERE. The FFE has already 02606 * lowered WHERE blocks into WHERE statements, 02607 * so the ELSE clause of the WHERE is always 02608 * a empty block. The mask is a temp, or an 02609 * lnot of a temp. 02610 * 02611 * TOS has the rhs, mask and expression. Tack 02612 * an OPC_ARRAYEXP around the mask. Change the 02613 * current block for the expression under the 02614 * mask, then make an empty block, then switch 02615 * back the original block to append the OPC_WHERE 02616 * (and subsequent stmts) 02617 * 02618 *=============================================== 02619 */ 02620 extern void 02621 fei_where(INT32 defined_asg, 02622 INT32 inline_state) 02623 { 02624 WN *msk ; 02625 WN *wn ; 02626 WN *wl ; 02627 TYPE dummy_type; 02628 INT64 flags = 0; 02629 02630 msk = cwh_expr_operand(NULL); 02631 02632 /* msk = F90_Wrap_ARREXP(msk); */ 02633 /* since we keep the logical expression in 02634 * the "where" block,the mask is no longer 02635 * temporary variable,therefore we cannot call F90_Wrap_ARREXP 02636 * to generate OPR_ARREXPR here 02637 */ 02638 02639 wl = cwh_block_new_and_current(); 02640 02641 wn = WN_Create(OPC_WHERE,3); 02642 WN_kid0(wn) = msk ; 02643 WN_kid1(wn) = cwh_block_current(); 02644 02645 if (defined_asg) { 02646 dummy_type = fei_descriptor(0, 02647 Basic, 02648 0, 02649 V_oid, 02650 0, 02651 0); 02652 fei_call(2, dummy_type, By_Value_Call, FALSE, inline_state, flags); 02653 } 02654 else { 02655 /* eraxxon: initialize to avoid warnings */ 02656 memset(&dummy_type, 0, sizeof(dummy_type)); 02657 fei_store(dummy_type); /* It's OK for this to be uninitialized */ 02658 } 02659 02660 (void) cwh_block_new_and_current(); 02661 02662 WN_kid2(wn) = cwh_block_current(); 02663 02664 cwh_block_set_current(wl); 02665 cwh_block_append(wn); 02666 02667 } 02668 02669 /*=============================================== 02670 * 02671 * fei_stop 02672 * 02673 * Generate a INTRIN_F90_STOP 02674 * 02675 * A scalar character stop code is on the stack. 02676 * 02677 *=============================================== 02678 */ 02679 02680 extern void 02681 fei_stop( void ) 02682 { 02683 WN *wa; 02684 WN *wc; 02685 WN *wn; 02686 WN *stop_code; 02687 WN *stop_code_len; 02688 02689 if (cwh_stk_get_class() == STR_item) { 02690 cwh_stk_pop_STR(); 02691 wa = cwh_stk_pop_WN(); 02692 wc = WN_COPY_Tree(wa); 02693 stop_code_len = cwh_intrin_wrap_value_parm(wa); 02694 wa = cwh_stk_pop_ADDR(); 02695 stop_code = cwh_intrin_wrap_char_parm(wa,wc); 02696 } 02697 else { 02698 DevAssert((0),("expected character stop code")); 02699 } 02700 02701 wn = WN_Create ( OPC_VINTRINSIC_CALL, 2); 02702 WN_Set_Call_Default_Flags(wn); 02703 02704 if (FE_Call_Never_Return) 02705 WN_Set_Call_Never_Return (wn); 02706 02707 WN_kid0(wn) = stop_code; 02708 WN_kid1(wn) = stop_code_len; 02709 02710 WN_intrinsic(wn) = INTRN_STOP_F90; 02711 02712 cwh_block_append(wn); 02713 } 02714 02715 /*=============================================== 02716 * 02717 * fei_return 02718 * 02719 * Generate a return - kind == 2 is void, so 02720 * just return. kind == 1 is a value, in a result 02721 * variable whose ST is TOS. kind =3 is an alternate 02722 * return whose index is a constant on the stack. 02723 * 02724 * If returning 02725 * - a scalar, in registers, then load the value 02726 * and store into a preg. The exception is CQ 02727 * results which have dummy arg introduced as 02728 * a ref to the result. 02729 * 02730 * - a character result, it's passed as a dummy, 02731 * but makes it here. A CASSIGNMENT has already 02732 * been done, so punt. 02733 * 02734 * - a derived type, larger than 16 bytes it's 02735 * passed as a dummy. Punt, we've done the store. 02736 * Smaller than 16 bytes it's returned in regs. 02737 * 02738 * If it's an alternate entry point, we just get 02739 * the ST of the last entry, so ignore it. Put 02740 * out a float and an integer version of the result, 02741 * if both are required. 02742 * 02743 * if an ST isn't TOS, then the WN/FLD is an 02744 * expression which will be an alternate return index. 02745 * 02746 *=============================================== 02747 */ 02748 /*ARGSUSED*/ 02749 extern void 02750 fei_return(INT return_kind, TYPE dummy) 02751 { 02752 WN * wn; 02753 WN * ret_wn = NULL; 02754 ST * st; 02755 ST * rt; 02756 TY_IDX ty; 02757 02758 TYPE_ID bt; 02759 02760 BOOL done_int; 02761 BOOL done_float; 02762 02763 DevAssert(((return_kind >= 1) && (return_kind <= 3)), 02764 (" odd return kind ")); 02765 02766 if (( return_kind == 1 ) || 02767 ( return_kind == 3 )) { 02768 02769 switch (cwh_stk_get_class()) { 02770 case ST_item: 02771 case ST_item_whole_array: 02772 st = cwh_stk_pop_ST(); 02773 ty = ST_type(st); 02774 02775 if ( WHIRL_Return_Val_On ) { 02776 02777 if((ST_sclass(st) == SCLASS_FORMAL) && 02778 (TY_kind(ty) == KIND_POINTER)) 02779 ty = TY_pointed(ty); 02780 02781 if ((TY_kind(ty) == KIND_SCALAR || 02782 TY_kind(ty) == KIND_STRUCT) && 02783 (! ST_auxst_is_rslt_tmp(st)) && 02784 (! cwh_types_is_character(ty))) { 02785 02786 ret_wn = cwh_stmt_return_scalar(st,NULL,ST_type(st),TRUE); 02787 } 02788 else { 02789 /* void return */ 02790 ret_wn = WN_CreateReturn(); 02791 } 02792 } 02793 else { 02794 02795 if (!IS_ALTENTRY_TEMP(st)) { 02796 02797 if((ST_sclass(st) == SCLASS_FORMAL) && 02798 (TY_kind(ty) == KIND_POINTER)) 02799 ty = TY_pointed(ty); 02800 02801 if ((TY_kind(ty) == KIND_SCALAR) && 02802 (! ST_auxst_is_rslt_tmp(st)) && 02803 (! cwh_types_is_character(ty))) { 02804 02805 ret_wn = cwh_stmt_return_scalar(st,NULL,ST_type(st),TRUE); 02806 02807 } else if (STRUCT_BY_VALUE(ty)) { 02808 (void) cwh_stmt_return_scalar(st,NULL,ST_type(st),TRUE); 02809 02810 } else { 02811 /* void return */ 02812 ret_wn = WN_CreateReturn(); 02813 } 02814 02815 } else { 02816 02817 done_int = FALSE; 02818 done_float = FALSE; 02819 02820 02821 ITEM *re = NULL; 02822 while ((re = cwh_auxst_next_element(ST_base(st),re,l_RETURN_TEMPS)) != NULL ) { 02823 rt = I_element(re); 02824 bt = TY_mtype(ST_type(rt)); 02825 02826 if (MTYPE_is_float(bt)) { 02827 if (! done_float) { 02828 done_float = TRUE; 02829 cwh_stmt_return_altentry(rt); 02830 } 02831 } else if (! done_int) { 02832 done_int = TRUE; 02833 cwh_stmt_return_altentry(rt); 02834 } 02835 } 02836 } 02837 } 02838 break; 02839 02840 02841 case WN_item: 02842 case WN_item_whole_array: 02843 case DEREF_item: 02844 wn = cwh_expr_operand(NULL); 02845 ty = Be_Type_Tbl(WNRTY(wn)); 02846 ret_wn = cwh_stmt_return_scalar(NULL,wn,ty,TRUE); 02847 break; 02848 02849 02850 case FLD_item: 02851 ty = cwh_stk_get_FLD_TY(); 02852 wn = cwh_expr_operand(NULL); 02853 ret_wn = cwh_stmt_return_scalar(NULL,wn,ty,TRUE); 02854 break; 02855 02856 default: 02857 DevAssert((0),("Odd return")); 02858 02859 } 02860 02861 if ( WHIRL_Return_Val_On ) { 02862 if (ret_wn != NULL) { 02863 cwh_block_append(ret_wn); 02864 } 02865 } 02866 else { 02867 wn = WN_CreateReturn(); 02868 cwh_block_append(wn) ; 02869 } 02870 } 02871 else { 02872 /* void return, return_kind == 2 */ 02873 wn = WN_CreateReturn(); 02874 cwh_block_append(wn) ; 02875 } 02876 } 02877 02878 /*=============================================== 02879 * 02880 * cwh_stmt_return_scalar 02881 * 02882 * Utility for fei_return and fei_call. Takes a 02883 * scalar ST/WN, and reads/writes the value and 02884 * returns it in the correct preg. The TY is the 02885 * that of the result (eg: of the ST, if present) 02886 * 02887 * If this is in a callee, the ST of the result 02888 * variable is loaded, and put into a preg, 02889 * or if ST is NULL and a WN is present 02890 * (eg: a constant), that's put into the preg 02891 * 02892 * In a caller the result WN has a load of the preg, 02893 * the ST is usually NULL and the TY is that of the 02894 * value. If its a struct by value, then there is 02895 * a result temp, and a NULL is returned (don't 02896 * push it as there won't be an fei_store..) 02897 * 02898 * If a call the result WN has a load of the preg, 02899 * the ST is NULL and the TY is that of the value. 02900 * 02901 *=============================================== 02902 */ 02903 extern WN * 02904 cwh_stmt_return_scalar(ST *st, WN * rv, TY_IDX rty, BOOL callee_return) 02905 { 02906 TYPE_ID rbtype1; 02907 TYPE_ID rbtype2; 02908 PREG_NUM rreg1; 02909 PREG_NUM rreg2; 02910 02911 02912 WN * wn ; 02913 WN * wn2 ; 02914 ST * pr1 ; 02915 ST * pr2 ; 02916 OFFSET_64 off; 02917 02918 if (WHIRL_Return_Info_On) { 02919 02920 RETURN_INFO return_info = Get_Return_Info (rty, Use_Simulated); 02921 02922 if (RETURN_INFO_count(return_info) <= 2 || 02923 WHIRL_Return_Val_On) { 02924 02925 rbtype1 = RETURN_INFO_mtype (return_info, 0); 02926 rbtype2 = RETURN_INFO_mtype (return_info, 1); 02927 rreg1 = RETURN_INFO_preg (return_info, 0); 02928 rreg2 = RETURN_INFO_preg (return_info, 1); 02929 } 02930 02931 else 02932 Fail_FmtAssertion ("cwh_stmt_return_scalar: more than 2 return registers"); 02933 } 02934 02935 else { 02936 Get_Return_Mtypes(rty, Use_Simulated, &rbtype1, &rbtype2); 02937 Get_Return_Pregs(rbtype1, rbtype2, &rreg1, &rreg2); 02938 } 02939 02940 pr1 = MTYPE_To_PREG(rbtype1); 02941 pr2 = MTYPE_To_PREG(rbtype2); 02942 02943 if (callee_return) { 02944 02945 if ( WHIRL_Return_Val_On ) { 02946 if (st == NULL) { 02947 wn = WN_CreateReturn_Val (OPR_RETURN_VAL, TY_mtype (rty), MTYPE_V, rv); 02948 Set_PU_has_very_high_whirl (Get_Current_PU ()); 02949 } 02950 else { 02951 02952 # ifdef linux 02953 wn2 = cwh_addr_load_ST(st,0,0); 02954 wn = WN_CreateReturn_Val (OPR_RETURN_VAL, TY_mtype (rty), MTYPE_V, wn2); 02955 # else 02956 if (IS_ALTENTRY_TEMP(st)) { 02957 wn2 = cwh_addr_ldid(ST_base(st),0,ST_type(ST_base(st))); 02958 wn = WN_CreateReturn_Val (OPR_RETURN_VAL, TY_mtype (ST_type(ST_base(st))), MTYPE_V, wn2); 02959 } else { 02960 wn2 = cwh_addr_load_ST(st,0,NULL); 02961 wn = WN_CreateReturn_Val (OPR_RETURN_VAL, TY_mtype (rty), MTYPE_V, wn2); 02962 } 02963 # endif 02964 02965 Set_PU_has_very_high_whirl (Get_Current_PU ()); 02966 } 02967 } 02968 else { 02969 if (st == NULL) 02970 cwh_addr_store_ST(pr1,rreg1,rty,rv); 02971 02972 else { 02973 02974 if (TY_kind(ST_type(st)) == KIND_STRUCT) { 02975 02976 wn = cwh_addr_mk_ldid(st,0,rbtype1,rty); 02977 cwh_addr_store_ST(pr1,rreg1,Be_Type_Tbl(rbtype1),wn); 02978 02979 if (rreg2 !=0) { 02980 02981 off = PREG2_OFFSET(pr1,pr2); 02982 wn = cwh_addr_mk_ldid(st,off,rbtype2,rty); 02983 cwh_addr_store_ST(pr2,rreg2,Be_Type_Tbl(rbtype2),wn); 02984 } 02985 02986 } else if (IS_ALTENTRY_TEMP(st)) { 02987 02988 wn = cwh_addr_ldid(ST_base(st),0,rty); 02989 cwh_addr_store_ST(pr1,rreg1,rty,wn); 02990 02991 } else { 02992 02993 wn = cwh_addr_load_ST(st,0,0); 02994 cwh_addr_store_ST(pr1,rreg1,rty,wn); 02995 } 02996 } 02997 } 02998 } else { /* caller return */ 02999 03000 if ( WHIRL_Return_Val_On ) { 03001 wn = cwh_addr_mk_ldid(Return_Val_Preg,-1, TY_mtype (rty), rty); 03002 03003 03004 if (STRUCT_BY_VALUE(rty)) { 03005 03006 /* result into temp that was 1st arg, & don't push result WN */ 03007 03008 cwh_addr_store_ST(st,0,rty,wn); 03009 wn = NULL; 03010 } 03011 } 03012 else { 03013 /* caller - read result in pregs - if struct return */ 03014 /* temp store pregs into temp, return temp */ 03015 03016 wn = cwh_addr_load_ST(pr1,rreg1,Be_Type_Tbl(rbtype1)); 03017 03018 } 03019 } 03020 03021 return wn; 03022 } 03023 03024 /*=============================================== 03025 * 03026 * cwh_stmt_return_altentry 03027 * 03028 * Utility for fei_return to return a shared altentry 03029 * result temp. This contains special return values. 03030 * 03031 *=============================================== 03032 */ 03033 static void 03034 cwh_stmt_return_altentry(ST *st) 03035 { 03036 TYPE_ID rbtype1; 03037 TYPE_ID rbtype2; 03038 TYPE_ID bt; 03039 03040 PREG_NUM rreg1; 03041 PREG_NUM rreg2; 03042 03043 WN * wn; 03044 WN * wn2; 03045 ST * pr; 03046 TY_IDX rty; 03047 ST ** p; 03048 BOOL same; 03049 03050 03051 same = ST_auxst_altentry_shareTY(ST_base(st)); 03052 rty = cwh_stab_altentry_TY(st,same); 03053 03054 if (TY_mtype(rty) == MTYPE_CQ) { 03055 03056 p = cwh_auxst_arglist(Procedure_ST) ; 03057 wn = cwh_addr_load_ST(st,0,0); 03058 03059 if ( WHIRL_Return_Val_On ) { 03060 wn2 = WN_CreateReturn_Val (OPR_RETURN_VAL, TY_mtype (rty), MTYPE_V, wn); 03061 cwh_block_append(wn2); 03062 Set_PU_has_very_high_whirl (Get_Current_PU ()); 03063 } 03064 else { 03065 cwh_addr_store_ST(p[0],0,0,wn); 03066 } 03067 03068 } else { 03069 03070 if ( WHIRL_Return_Val_On ) { 03071 03072 wn = cwh_addr_ldid(ST_base(st),0,rty); 03073 03074 wn2 = WN_CreateReturn_Val (OPR_RETURN_VAL, TY_mtype (rty), MTYPE_V, wn); 03075 cwh_block_append(wn2); 03076 Set_PU_has_very_high_whirl (Get_Current_PU ()); 03077 } 03078 else { 03079 if (WHIRL_Return_Info_On) { 03080 03081 RETURN_INFO return_info = Get_Return_Info (rty, Use_Simulated); 03082 03083 if (RETURN_INFO_count(return_info) <= 2) { 03084 03085 rbtype1 = RETURN_INFO_mtype (return_info, 0); 03086 rbtype2 = RETURN_INFO_mtype (return_info, 1); 03087 rreg1 = RETURN_INFO_preg (return_info, 0); 03088 rreg2 = RETURN_INFO_preg (return_info, 1); 03089 } 03090 03091 else 03092 Fail_FmtAssertion ("cwh_stmt_alt_entry: more than 2 return registers"); 03093 } 03094 03095 else { 03096 Get_Return_Mtypes(rty, Use_Simulated, &rbtype1, &rbtype2); 03097 Get_Return_Pregs(rbtype1, rbtype2, &rreg1, &rreg2); 03098 } 03099 03100 pr = MTYPE_To_PREG(rbtype1); 03101 03102 wn = cwh_addr_ldid(ST_base(st),0,rty); 03103 bt = TY_mtype(rty); 03104 03105 if (MTYPE_is_float(bt) && !same) { 03106 03107 if (bt == MTYPE_C4) { 03108 wn = WN_CreateStid (OPC_C4STID, 32, Float32_Preg,rty,wn); 03109 cwh_block_append(wn); 03110 } else if (TY_size(rty) <= TY_size(Be_Type_Tbl(MTYPE_F8))) 03111 cwh_addr_store_ST(pr,rreg1,rty,wn); 03112 else { 03113 wn = WN_CreateStid (OPC_FQSTID, 32, Float64_Preg, rty, wn ); 03114 cwh_block_append(wn); 03115 } 03116 03117 } else 03118 cwh_addr_store_ST(pr,rreg1,rty,wn); 03119 } 03120 } 03121 } 03122 03123 /*=============================================== 03124 * 03125 * fei_concat 03126 * 03127 * Generate the intrinsic for concatenation. 03128 * The number of operands is the number of 03129 * STR_items to pop from the stack. Addresses go 03130 * in the first half of the argument list, lengths 03131 * in the second half. 03132 * 03133 * A destination temp is allocated here, used as 03134 * 0'th arg (length 1st arg) , pushed onto the 03135 * stack and will be copied by fei_store. 03136 * 03137 *=============================================== 03138 */ 03139 extern void 03140 fei_concat(INT32 numops) 03141 { 03142 INT32 i,nm,k,sc; 03143 WN ** sz ; 03144 WN ** wn ; 03145 WN * rsz; 03146 WN * wt ; 03147 WN * ae ; 03148 WN * wwnn; 03149 TY_IDX ty ; 03150 BOOL *va ; 03151 WN *wr; 03152 03153 ae = NULL ; 03154 sc = numops; 03155 03156 nm = 2 * sc ; 03157 sz = (WN **) malloc((nm+1) * sizeof(WN *)) ; 03158 wn = (WN **) malloc((nm+1) * sizeof(WN *)) ; 03159 va = (BOOL *) malloc((nm+1) * sizeof(BOOL)) ; 03160 rsz = WN_Zerocon(cwh_bound_int_typeid); 03161 03162 for (i = sc ; i >= 1 ; i--) { 03163 k = i + numops ; 03164 switch (cwh_stk_get_class()) { 03165 case STR_item: 03166 cwh_stk_pop_STR(); 03167 wn[k] = cwh_stk_pop_WN(); 03168 wn[i] = F90_Wrap_ARREXP(cwh_expr_address(f_T_PASSED)); 03169 if (WNOPR(wn[i]) == OPR_ARRAYEXP) 03170 ae = wn[i] ; 03171 sz[k] = NULL; 03172 sz[i] = WN_COPY_Tree(wn[k]) ; 03173 va[k] = TRUE; 03174 va[i] = FALSE; 03175 rsz = cwh_expr_bincalc(OPR_ADD,rsz,WN_COPY_Tree(wn[k])); 03176 break; 03177 03178 case WN_item: 03179 wn[i] = cwh_stk_pop_WN(); 03180 wn[k] = rsz; 03181 sz[k] = rsz; 03182 sz[i] = WN_COPY_Tree(wn[i]); 03183 va[k] = TRUE; 03184 va[i] = TRUE; 03185 rsz = cwh_expr_bincalc(OPR_ADD,rsz,rsz); 03186 break; 03187 03188 default: 03189 DevAssert((0),("Odd string")); 03190 } 03191 } 03192 03193 /* if an ARRAYEXP (ae) appeared it was an elemental */ 03194 /* concat and an array valued temp is needed */ 03195 03196 ty = cwh_types_mk_character_TY(WN_COPY_Tree(rsz),NULL,TRUE); 03197 03198 #if 0 03199 if (ae != NULL) { 03200 ty = cwh_types_array_temp_TY(ae,ty) ; 03201 wt = cwh_expr_temp(ty,WN_COPY_Tree(rsz),f_T_PASSED); 03202 wt = cwh_addr_temp_section(wt,ty); 03203 wr = WN_COPY_Tree(wt); 03204 wt = F90_Wrap_ARREXP(wt); 03205 } else { 03206 wt = cwh_expr_temp(ty,WN_COPY_Tree(rsz),f_T_PASSED); 03207 wr = WN_COPY_Tree(wt) ; 03208 } 03209 # endif 03210 03211 03212 wn[0] = WN_COPY_Tree(rsz) ; 03213 sz[0] = NULL ; 03214 va[0] = TRUE ; 03215 03216 wwnn = cwh_intrin_call(INTRN_CONCATEXPR,nm,wn,sz,va,MTYPE_V); 03217 03218 cwh_stk_push_STR(rsz,wwnn,ty,WN_item); 03219 03220 free(va); 03221 free(wn); 03222 free(sz); 03223 } 03224 03225 /*=============================================== 03226 * 03227 * cwh_stmt_character_icall 03228 * 03229 * This is a character intrinsic call. The stack contains 03230 * two STR items - second argument on top. Pop the length 03231 * and address of each side, then make the 03232 * intrinsic call. 03233 * (args are addr_lhs,addr_rhs,sz_lhs,sz_rhs) 03234 * 03235 * Sizes are passed to create OPC_PARM types. 03236 * 03237 *=============================================== 03238 */ 03239 extern void 03240 cwh_stmt_character_icall(INTRINSIC intrinsic) 03241 { 03242 WN * ar[4]; 03243 WN * sz[4]; 03244 BOOL va[4]; 03245 03246 cwh_stk_pop_STR(); 03247 ar[3] = cwh_expr_operand(NULL); 03248 ar[1] = cwh_expr_address(f_NONE); 03249 ar[1] = F90_Wrap_ARREXP(ar[1]); 03250 03251 sz[3] = NULL; 03252 sz[1] = WN_COPY_Tree(ar[3]); 03253 va[3] = TRUE; 03254 va[1] = FALSE; 03255 03256 cwh_stk_pop_STR(); 03257 ar[2] = cwh_expr_operand(NULL); 03258 ar[0] = cwh_expr_address(f_NONE); 03259 ar[0] = F90_Wrap_ARREXP(ar[0]); 03260 03261 sz[2] = NULL; 03262 sz[0] = WN_COPY_Tree(ar[2]); 03263 va[2] = TRUE; 03264 va[0] = FALSE; 03265 03266 cwh_intrin_call(intrinsic,4,ar,sz,va,MTYPE_V); 03267 } 03268 03269 /*=============================================== 03270 * 03271 * cwh_stmt_add_to_preamble 03272 * 03273 * Append the pragma WN argument to the callsite 03274 * block of the preamble. Check to see if the 03275 * blocks have been set up - if not, then this 03276 * called from the declaration setup eg: a bounds 03277 * expression in an ARRAY TY, so it's ignored. 03278 * 03279 *=============================================== 03280 */ 03281 extern BOOL 03282 cwh_stmt_add_to_preamble(WN *wn, enum site block, 03283 enum pu_pragma_placement_t placement) 03284 { 03285 BOOL res = FALSE; 03286 03287 if (block == block_ca) { 03288 if (WN_pragma_ca != NULL) { 03289 if (placement == pu_pragma_placement_first) { 03290 WN_INSERT_BlockFirst (WN_pragma_ca,wn); 03291 } 03292 else if (placement == pu_pragma_placement_last) { 03293 WN_INSERT_BlockLast (WN_pragma_ca,wn); 03294 } 03295 res = TRUE; 03296 } 03297 } 03298 else if (block == block_pu) { 03299 if (WN_pragma_pu != NULL) { 03300 if (placement == pu_pragma_placement_first) { 03301 WN_INSERT_BlockFirst (WN_pragma_pu,wn); 03302 } 03303 else if (placement == pu_pragma_placement_last) { 03304 WN_INSERT_BlockLast (WN_pragma_pu,wn); 03305 } 03306 res = TRUE; 03307 } 03308 } 03309 03310 return res; 03311 } 03312 03313 /*=============================================== 03314 * 03315 * cwh_stmt_add_pragma 03316 * 03317 * Generate a PRAGMA node and add to the current 03318 * block. All args except the id are default NULL. 03319 * 03320 *=============================================== 03321 */ 03322 extern void 03323 cwh_stmt_add_pragma(WN_PRAGMA_ID wn_pragma_id, 03324 BOOL is_omp, 03325 ST *st, 03326 INT32 arg1, 03327 INT32 arg2) 03328 { 03329 WN *wn; 03330 wn = WN_CreatePragma(wn_pragma_id, st, arg1, arg2); 03331 if (is_omp) 03332 WN_set_pragma_omp(wn); 03333 cwh_block_append(wn); 03334 } 03335 03336 /*=============================================== 03337 * 03338 * cwh_stmt_add_xpragma 03339 * 03340 * Generate a XPRAGMA node with a single kid 03341 * and add to the current block. Arg will be kid0 03342 * of xpragma. Omp and expr are default NULL. 03343 * 03344 *=============================================== 03345 */ 03346 extern void 03347 cwh_stmt_add_xpragma(WN_PRAGMA_ID wn_pragma_id, 03348 BOOL is_omp, 03349 WN * expr) 03350 { 03351 WN *wn; 03352 wn = WN_CreateXpragma(wn_pragma_id, (ST_IDX) NULL, 1); 03353 WN_kid0(wn) = expr; 03354 if (is_omp) 03355 WN_set_pragma_omp(wn); 03356 cwh_block_append(wn); 03357 } 03358 03359 /*================================================================ 03360 * 03361 * fei_enddo 03362 * 03363 * Pop the DOLOOP block, & leave block of loop body. 03364 * 03365 *================================================================ 03366 */ 03367 void 03368 fei_enddo(void) 03369 { 03370 WN *wn; 03371 03372 if (FE_Endloop_Marker) { 03373 wn = WN_CreateComment("ENDLOOP"); 03374 cwh_block_append(wn); 03375 cwh_auxst_clear(WN_st(wn)); 03376 } 03377 03378 cwh_block_pop_block(); 03379 } 03380 03381 /*================================================================ 03382 * 03383 * fei_dowhile 03384 * 03385 * Create a OPC_DOWHILE. TOS has the expression to 03386 * be evaluated. Push the current block and build the 03387 * body in a new block. 03388 * 03389 *================================================================ 03390 */ 03391 void 03392 fei_dowhile(void) 03393 { 03394 WN *expr,*block,*w; 03395 03396 expr = cwh_expr_operand(NULL); 03397 block = WN_CreateBlock(); 03398 WN_Set_Linenum (block, USRCPOS_srcpos(current_srcpos)); 03399 w = WN_CreateWhileDo(expr,block); 03400 cwh_block_append(w); 03401 03402 /* Push current block & set new block for body */ 03403 03404 cwh_block_push_block(NULL,NULL,FALSE); 03405 cwh_block_set_current(block); 03406 } 03407 03408 /*================================================================ 03409 * 03410 * fei_doloop 03411 * 03412 * Create a OPC_DOLOOP. TOS has stride, then ub,lb, variable. 03413 * 03414 * First check stride and upper bound, and if expressions move 03415 * into temps. Then if it's a float loop variable or the stride 03416 * isn't constant or the loop variable is a pointer the loop 03417 * is canonlicalized - count is computed the increment is set 03418 * to one and the user's index variable is kept up to date 03419 * by adding the stride on each iteration. This is done by 03420 * maintaining a list of statements which are deferred to 03421 * the end of the loop body. A new BLOCK is created and set 03422 * current to contain the body. 03423 * 03424 * For parallel loops, we calculate the user index var based on the 03425 * normalized index var if the loop is canonlicalized. 03426 * 03427 * for source-to-source translation we don't do any manipulation 03428 * on the loop variable and strid,ub,lb--fzhao 03429 * 03430 *================================================================ 03431 */ 03432 03433 void 03434 fei_doloop(INT32 line) 03435 { 03436 WN *lb; 03437 WN *ub,*ubcomp; 03438 WN *stride,*stride_in_loop; 03439 ST *lcv; 03440 WN *index_id; 03441 WN *stmts; 03442 WN *start; 03443 WN *end; 03444 WN *step; 03445 WN *wlcv = NULL; 03446 TY_IDX ty; 03447 03448 USRCPOS pos; 03449 INT32 local_line_num; 03450 mUINT16 local_file_num; 03451 03452 TYPE_ID doloop_ty,lcv_t; 03453 BOOL canonicalize; 03454 PREG_NUM loop_preg; 03455 WN *temp, *count; 03456 WN *deferred_update=NULL; /* ie: deferred to end of loop body */ 03457 WN *calcu=NULL; /* calculate user index var */ 03458 03459 WN *doloop; 03460 WN *body; 03461 03462 /* 03463 example: 03464 C$DOACROSS NEST(i,j,k) 03465 DO i <- is_nested=FALSE 03466 DO j <- is_nested=TRUE 03467 DO k <- is_nested=TRUE 03468 DO l <- is_nested=FALSE 03469 */ 03470 03471 BOOL is_top_pdo=FALSE; /* is this the outermost loop of a PDO? */ 03472 BOOL is_innermost=FALSE; /* is innermost loop of a nest (if true if not 03473 nested) */ 03474 BOOL source_to_source = TRUE; 03475 03476 if ((nested_do_descriptor.type == WN_PRAGMA_PDO_BEGIN || 03477 nested_do_descriptor.type == WN_PRAGMA_PARALLEL_DO) && 03478 nested_do_descriptor.explicit_end && 03479 nested_do_descriptor.current==0 && 03480 nested_do_descriptor.depth!=0) { 03481 is_top_pdo=TRUE; 03482 } 03483 03484 03485 if (nested_do_descriptor.depth!=0) { 03486 03487 /* if a nested parallel do, generate a region for it */ 03488 03489 if (nested_do_descriptor.current>0) { 03490 03491 body=cwh_mp_region(nested_do_descriptor.type,0,0,0,0,0,0); 03492 cwh_block_set_current(body); 03493 } 03494 03495 nested_do_descriptor.current++; 03496 03497 if (nested_do_descriptor.current >= nested_do_descriptor.depth) { 03498 /* this is the last nest, reset the descriptor */ 03499 nested_do_descriptor.depth = 0; 03500 nested_do_descriptor.current = 0; 03501 is_innermost=TRUE; 03502 } 03503 } 03504 03505 03506 canonicalize = FALSE; 03507 03508 stride = cwh_expr_operand(NULL); 03509 ub = cwh_expr_operand(NULL); 03510 lb = cwh_expr_operand(NULL); 03511 03512 /* loop control variable may be ST, or DEREF of pointer - get type */ 03513 03514 if (cwh_stk_get_class() == ST_item || cwh_stk_get_class() == ST_item_whole_array) { 03515 03516 lcv = cwh_stk_pop_ST(); 03517 if (ST_sclass(lcv) == SCLASS_FORMAL) { 03518 lcv_t = TY_mtype(TY_pointed(ST_type(lcv))); 03519 canonicalize = TRUE; 03520 } else { 03521 lcv_t = TY_mtype(ST_type(lcv)); 03522 } 03523 03524 } else { 03525 wlcv = cwh_stk_pop_WHIRL(); 03526 ty = cwh_types_WN_TY(wlcv,FALSE); 03527 lcv_t = TY_mtype(cwh_types_scalar_TY(ty)); 03528 canonicalize = TRUE; 03529 } 03530 03531 /* create pregs for non-constant bounds or strides */ 03532 /* or for inconvenient types eg: real do loop varbls */ 03533 03534 lb = cwh_convert_to_ty(lb,lcv_t); 03535 ub = cwh_convert_to_ty(ub,lcv_t); 03536 stride = cwh_convert_to_ty(stride,lcv_t); 03537 03538 if (lcv_t != MTYPE_I4 && lcv_t != MTYPE_I8) { 03539 canonicalize = TRUE; 03540 doloop_ty = cwh_doloop_typeid; 03541 } else { 03542 doloop_ty = lcv_t; 03543 } 03544 03545 if (WNOPR(stride) != OPR_INTCONST && ! is_top_pdo && !source_to_source) { 03546 /* do not canonicalize the PDO loops, to avoid emitting unvalid code ([email protected]) */ 03547 /* (e.g. PDO region which does not start with a DO loop) */ 03548 /* if they are to be canonicalized, the code introduced must be moved outside the region */ 03549 canonicalize = TRUE; 03550 } 03551 if (WNOPR(stride) != OPR_INTCONST && WNOPR(stride) != OPR_CONST && 03552 /* do not canonicalize the PDO loops, to avoid emitting unvalid code ([email protected]) */ 03553 /* (e.g. PDO region which does not start with a DO loop) */ 03554 /* if they are to be canonicalized, the code introduced must be moved outside the region */ 03555 ! is_top_pdo && !source_to_source) { 03556 stride_in_loop = cwh_preg_temp_save("doloop_stride",stride); 03557 } else { 03558 stride_in_loop = WN_COPY_Tree(stride); 03559 } 03560 03561 if (WNOPR(ub) != OPR_INTCONST && WNOPR(ub) != OPR_CONST && 03562 /* do not canonicalize the PDO loops, to avoid emitting unvalid code ([email protected]) */ 03563 /* (e.g. PDO region which does not start with a DO loop) */ 03564 /* if they are to be canonicalized, the code introduced must be moved outside the region */ 03565 ! is_top_pdo && !source_to_source) { 03566 ubcomp = cwh_preg_temp_save("doloop_ub",ub); 03567 } else { 03568 ubcomp = WN_COPY_Tree(ub); 03569 } 03570 03571 /* for loops which can be parallelized, make sure the */ 03572 /* lower bound is a constant or a preg */ 03573 03574 if (parallel_do_count) { 03575 03576 if (! ((WNOPR(lb) == OPR_INTCONST) || 03577 (WNOPR(lb) == OPR_LDID && ST_class(WN_st(lb)) == CLASS_PREG)) && 03578 ! is_top_pdo) { 03579 /* do not canonicalize the PDO loops, to avoid emitting unvalid code ([email protected]) */ 03580 /* (e.g. PDO region which does not start with a DO loop) */ 03581 /* if they are to be canonicalized, the code introduced must be moved outside the region */ 03582 lb = cwh_preg_temp_save("doloop_lb",lb); 03583 } 03584 } 03585 03586 if (canonicalize) { 03587 03588 /* Initialize lcv - it needs a temp */ 03589 03590 WN *wc ; 03591 03592 if (wlcv == NULL) { 03593 cwh_addr_store_ST(lcv,0,0,WN_COPY_Tree(lb)); 03594 wc = cwh_addr_load_ST(lcv,0,0) ; 03595 03596 } else { 03597 cwh_addr_store_WN(wlcv,0,0,WN_COPY_Tree(lb)); 03598 wc = cwh_addr_load_WN(wlcv,0,0) ; 03599 } 03600 03601 /* Compute iteration count */ 03602 temp = cwh_addr_extent(wc,ub,stride); 03603 count = cwh_convert_to_ty(temp,doloop_ty); 03604 03605 if (WNOPR(count) != OPR_INTCONST) { 03606 count = cwh_preg_temp_save("doloop_count",count); 03607 } 03608 loop_preg = Create_Preg(doloop_ty,Index_To_Str(Save_Str("doloop_var"))); 03609 index_id = WN_CreateIdname(loop_preg,MTYPE_To_PREG(doloop_ty)); 03610 03611 start = WN_StidPreg(doloop_ty,loop_preg,WN_Intconst(doloop_ty,0)); 03612 end = WN_CreateExp2(OPCODE_make_op(OPR_LT,MTYPE_I4,doloop_ty), 03613 WN_LdidPreg(doloop_ty,loop_preg), 03614 count); 03615 step = cwh_expr_bincalc(OPR_ADD,WN_LdidPreg(doloop_ty,loop_preg), 03616 WN_Intconst(doloop_ty,1)); 03617 step = WN_StidPreg(doloop_ty,loop_preg,step); 03618 03619 if (parallel_do_count) { /* parallel, calculate user index */ 03620 calcu = cwh_expr_bincalc(OPR_ADD,WN_COPY_Tree(lb), 03621 cwh_expr_bincalc(OPR_MPY, WN_LdidPreg(doloop_ty,loop_preg), stride_in_loop)); 03622 if (wlcv) 03623 calcu = cwh_addr_istore(wlcv,0,ty,calcu); 03624 else 03625 calcu = cwh_addr_stid(lcv,0,Be_Type_Tbl(lcv_t),calcu); 03626 03627 } else { /* not parallel, add stride to user index */ 03628 03629 deferred_update = cwh_expr_bincalc(OPR_ADD,WN_COPY_Tree(wc),stride_in_loop); 03630 if (wlcv) 03631 deferred_update = cwh_addr_istore(wlcv,0,ty,deferred_update); 03632 else 03633 deferred_update = cwh_addr_stid(lcv,0,Be_Type_Tbl(lcv_t),deferred_update); 03634 } 03635 03636 WN_DELETE_Tree(ubcomp); 03637 03638 } else { 03639 03640 OPERATOR op; 03641 03642 index_id = WN_CreateIdname(0,lcv); 03643 start = WN_Stid(lcv_t, 0, lcv, Be_Type_Tbl(lcv_t), lb); 03644 03645 /* Stride is an integer constant (+ve or -ve?)*/ 03646 03647 if (WNOPR(stride) == OPR_INTCONST 03648 || 03649 WNOPR(stride) == OPR_CONST) { 03650 if ( WN_const_val(stride) > 0) 03651 op = OPR_LE; 03652 else 03653 op = OPR_GE; 03654 } 03655 else { 03656 /* prior to this change we always 03657 assumed if the stride is not constant > 0 03658 then the operator should be GE but this 03659 is obviously wrong if the stride is a variable which 03660 could of course be either. On unparsing 03661 it didn't matter because this kind of do loop 03662 was unparsed to the fortran syntax ommitting 03663 the comparison operator. 03664 Now, with assuming NE it is 03665 at least indicating an uncertain direction 03666 even though it is not logically correct in general either 03667 because nothing requires to hit the loop bound exactly. 03668 the stride is not equal +- 1. */ 03669 op = OPR_NE; 03670 } 03671 03672 end = WN_CreateExp2(OPCODE_make_op(op,MTYPE_I4,Mtype_comparison(lcv_t)), 03673 WN_Ldid(lcv_t,0,lcv,ST_type(lcv)), 03674 ubcomp); 03675 step = cwh_expr_bincalc(OPR_ADD,WN_Ldid(lcv_t,0,lcv,ST_type(lcv)), 03676 stride_in_loop); 03677 step = WN_Stid(lcv_t, 0, lcv, ST_type(lcv), step); 03678 deferred_update = NULL; 03679 } 03680 03681 stmts = WN_CreateBlock(); 03682 WN_Set_Linenum (start, USRCPOS_srcpos(current_srcpos) ); 03683 03684 03685 if (line > 0) { /* 0 means no line number */ 03686 USRCPOS_clear(pos); 03687 USRCPOS_filenum(pos) = USRCPOS_filenum(current_srcpos); 03688 USRCPOS_linenum(pos) = global_to_local_line_number(line); 03689 WN_Set_Linenum (step, USRCPOS_srcpos(pos)); 03690 } 03691 else { 03692 WN_Set_Linenum (step, USRCPOS_srcpos(current_srcpos)); 03693 } 03694 03695 WN_Set_Linenum (stmts, USRCPOS_srcpos(current_srcpos) ); 03696 03697 doloop = WN_CreateDO(index_id, start, end, step, stmts, NULL); 03698 03699 cwh_directive_insert_do_loop_directives(); 03700 cwh_block_append(doloop); 03701 03702 /* Push the current block & make loop body current block */ 03703 03704 cwh_block_push_block(deferred_update,calcu,is_top_pdo); 03705 cwh_block_set_current(stmts); 03706 03707 /* Add any MP directives required to start of the loop body */ 03708 03709 if (is_innermost) 03710 cwh_block_append_given(Top_of_Loop_Block); 03711 03712 /* add calculation of the user index to the start of the loop body */ 03713 03714 if (calcu) { 03715 cwh_block_append(WN_COPY_Tree(calcu)); 03716 } 03717 return; 03718 } 03719 03720 /*================================================================ 03721 * 03722 * fei_doforever 03723 * 03724 * This is handled by a label & goto. Just keep the block 03725 * stack consistent for fei_enddo. 03726 * 03727 *================================================================ 03728 */ 03729 void 03730 fei_doforever(void) 03731 { 03732 /* Dummy block push */ 03733 cwh_block_push_block(NULL,NULL,FALSE); 03734 } 03735 03736 /*================================================================ 03737 * 03738 * fei_if 03739 * 03740 *================================================================ 03741 */ 03742 03743 void 03744 fei_if(void) 03745 { 03746 WN *test; 03747 WN *if_then; 03748 WN *if_else; 03749 WN *if_cnstrct; 03750 03751 test = cwh_expr_operand(NULL); 03752 03753 if_then = WN_CreateBlock(); 03754 if_else = WN_CreateBlock(); 03755 WN_Set_Linenum (if_else, USRCPOS_srcpos(current_srcpos) ); 03756 WN_Set_Linenum (if_then, USRCPOS_srcpos(current_srcpos) ); 03757 03758 if_cnstrct = WN_CreateIf(test, if_then, if_else); 03759 03760 cwh_block_append(if_cnstrct); 03761 03762 /* Push the current block */ 03763 cwh_block_push_block(NULL,NULL,FALSE); 03764 03765 cwh_block_set_current(if_then); 03766 03767 /* push the if_cnstrct on the stack */ 03768 cwh_stk_push(if_cnstrct, WN_item); 03769 03770 return; 03771 } 03772 03773 /*================================================================ 03774 * 03775 * fei_else 03776 * 03777 *================================================================ 03778 */ 03779 03780 void 03781 fei_else(void) 03782 { 03783 WN *if_else; 03784 WN *if_cnstrct; 03785 03786 /* pop off the if construct */ 03787 if_cnstrct = cwh_stk_pop_WN(); 03788 03789 /* get the else block */ 03790 if_else = WN_kid2(if_cnstrct); 03791 03792 cwh_block_set_current(if_else); 03793 03794 /* push the if_cnstrct back on the stack */ 03795 cwh_stk_push(if_cnstrct, WN_item); 03796 return; 03797 } 03798 03799 /*================================================================ 03800 * 03801 * fei_endif 03802 * 03803 * pop off the if construct from stack 03804 * 03805 *================================================================ 03806 */ 03807 void 03808 fei_endif(void) 03809 { 03810 WN *if_cnstrct; 03811 03812 if_cnstrct = cwh_stk_pop_WN(); 03813 03814 cwh_block_pop_block(); 03815 return; 03816 } 03817 03818 static ST *allocate_routine_st = NULL; 03819 03820 /*================================================================ 03821 * 03822 * cwh_inline_allocate 03823 * 03824 * Called for the ALLOCATE statement to do the allocation via the 03825 * ALLOCATE_SGI intrinsic.This exposes the bounds setup to the optimizer, 03826 * so bounds can be propagated. Otherwise the whole dope vector is 03827 * considered to be modified by a call to _ALLOCATE. 03828 * 03829 *================================================================ 03830 */ 03831 03832 static void 03833 cwh_inline_allocate(WN **dopes, TY_IDX *types, INT num_dopes, WN *stat) 03834 { 03835 INT idope,i; 03836 INT rank; 03837 WN *dope_addr; 03838 TY_IDX ty; 03839 TY_IDX el_ty; 03840 FLD_HANDLE fl; 03841 INT64 esize; 03842 INT64 flag_val; 03843 WN *size; 03844 WN *size2; 03845 WN *assoc; 03846 WN *flags; 03847 BOOL is_f90_pointer; 03848 WN *args[5]; 03849 WN *iop; 03850 PREG_NUM size_preg; 03851 PREG_NUM addr_preg; 03852 TY_IDX addr_ty; 03853 03854 /* Initialize stat to 0 */ 03855 if (WNOPR(stat) != OPR_INTCONST) { 03856 cwh_addr_store_WN(WN_COPY_Tree(stat),0,0,WN_Zerocon(MTYPE_I4)); 03857 } 03858 03859 if (!allocate_routine_st) { 03860 allocate_routine_st = cwh_intrin_make_intrinsic_symbol("_F90_ALLOCATE_B",Pointer_Mtype); 03861 } 03862 03863 03864 for (idope=0; idope < num_dopes; idope++) { 03865 dope_addr = dopes[idope]; 03866 03867 size_preg = Create_Preg(cwh_bound_int_typeid,Index_To_Str(Save_Str("size_preg"))); 03868 03869 /* Get the rank and size of the object from the type */ 03870 ty = types[idope]; 03871 if (TY_kind(ty) == KIND_POINTER) ty = TY_pointed(ty); 03872 03873 /* TY should be the TY of a dope vector Dope */ 03874 TY & tt = Ty_Table[ty]; 03875 is_f90_pointer = TY_is_f90_pointer(tt); 03876 03877 /* Compute the rank from the size of the dope vector */ 03878 rank = cwh_types_dope_rank(ty); 03879 03880 fl = TY_fld(tt); 03881 addr_ty = FLD_type(fl); 03882 ty = TY_pointed(addr_ty); /* this is the type of the object */ 03883 /* Create a temp symbol to hold the address */ 03884 addr_preg = Create_Preg(Pointer_Mtype,Index_To_Str(Save_Str("alloc_addr"))); 03885 03886 if (rank > 0) { 03887 el_ty = TY_AR_etype(ty); 03888 } else { 03889 el_ty = ty; 03890 } 03891 03892 esize = TY_size(el_ty); 03893 if (esize != 0) { 03894 size = WN_Intconst(cwh_bound_int_typeid,esize); 03895 } else { 03896 /* This must be an assumed-length character dummy */ 03897 /* Pick up the size from the element_size field */ 03898 cwh_stk_push(WN_COPY_Tree(dope_addr),WN_item); 03899 fei_get_dv_hdr_fld(2); 03900 size = cwh_expr_operand(NULL); 03901 } 03902 03903 size2 = WN_Int_Type_Conversion(size,MTYPE_I8); 03904 /* Build up the size in bytes */ 03905 for (i = 0; i < rank; i++) { 03906 cwh_stk_push(WN_COPY_Tree(dope_addr),WN_item); 03907 fei_get_dv_extent(i+1,0); 03908 size2 = cwh_expr_bincalc(OPR_MPY,cwh_expr_operand(NULL),size2); 03909 } 03910 size2 = WN_StidPreg(cwh_bound_int_typeid,size_preg,size2); 03911 cwh_block_append(size2); 03912 03913 03914 /* First step, set the flags bits if it's a pointer */ 03915 flag_val = 0; 03916 if (DEBUG_Trap_Uv) { 03917 flag_val |= 4; 03918 } 03919 if (is_f90_pointer) { 03920 cwh_stk_push(WN_COPY_Tree(dope_addr),WN_item); 03921 cwh_stk_push(WN_Intconst(MTYPE_I4,1),WN_item); 03922 fei_set_dv_hdr_fld(4); 03923 flag_val |= 1; 03924 } 03925 flags = WN_Intconst(MTYPE_I4,flag_val); 03926 03927 03928 /* get the value of assoc from the dope vector */ 03929 cwh_stk_push(WN_COPY_Tree(dope_addr),WN_item); 03930 fei_get_dv_hdr_fld(3); 03931 assoc = cwh_intrin_wrap_value_parm(cwh_expr_operand(NULL)); 03932 03933 /* Build up the call to the _ALLOCATE_SGI intrinsic */ 03934 args[0] = cwh_intrin_wrap_value_parm(WN_LdidPreg(cwh_bound_int_typeid,size_preg)); 03935 args[1] = assoc; 03936 args[2] = cwh_intrin_wrap_value_parm(flags); 03937 03938 if (WNOPR(stat) == OPR_INTCONST) { 03939 args[3] = cwh_intrin_wrap_value_parm(WN_COPY_Tree(stat)); 03940 } else { 03941 args[3] = cwh_intrin_wrap_ref_parm(WN_COPY_Tree(stat),0); 03942 } 03943 03944 /* fifth argument is the old value of the dope vector */ 03945 cwh_stk_push(WN_COPY_Tree(dope_addr),WN_item); 03946 fei_get_dv_hdr_fld(1); 03947 args[4] = cwh_intrin_wrap_value_parm(cwh_expr_operand(NULL)); 03948 03949 iop = WN_Create(opc_call,5); 03950 03951 for (i=0; i < 5; i++) { 03952 WN_kid(iop,i) = args[i]; 03953 } 03954 03955 /* Build the call to the allocate routine */ 03956 WN_st_idx(iop) = ST_st_idx(allocate_routine_st); 03957 WN_Set_Call_Does_Mem_Alloc(iop); 03958 WN_Set_Call_Non_Data_Mod(iop); 03959 WN_Set_Call_Parm_Mod(iop); 03960 WN_Set_Call_Parm_Ref(iop); 03961 cwh_block_append(iop); 03962 iop = cwh_stmt_return_scalar(NULL, NULL, Be_Type_Tbl(Pointer_Mtype), FALSE); 03963 iop = WN_StidPreg(Pointer_Mtype,addr_preg,iop); 03964 cwh_block_append(iop); 03965 03966 /* Add stores to base address, orig_base and orig_size */ 03967 /* base_address */ 03968 cwh_stk_push_typed(WN_COPY_Tree(dope_addr),WN_item, types[idope]); 03969 cwh_stk_push(WN_LdidPreg(Pointer_Mtype,addr_preg),WN_item); 03970 fei_set_dv_hdr_fld(1); 03971 03972 /* orig_base */ 03973 cwh_stk_push_typed(WN_COPY_Tree(dope_addr),WN_item, types[idope]); 03974 cwh_stk_push(WN_LdidPreg(Pointer_Mtype,addr_preg),WN_item); 03975 fei_set_dv_hdr_fld(9); 03976 03977 /* orig size */ 03978 cwh_stk_push(WN_COPY_Tree(dope_addr),WN_item); 03979 size = cwh_expr_bincalc(OPR_SHL,WN_LdidPreg(cwh_bound_int_typeid,size_preg), 03980 WN_Intconst(MTYPE_I4,3)); 03981 cwh_stk_push(size,WN_item); 03982 fei_set_dv_hdr_fld(10); 03983 03984 /* Finally, set the assoc bit if allocation was successful */ 03985 cwh_stk_push(WN_COPY_Tree(dope_addr),WN_item); 03986 assoc = WN_LdidPreg(Pointer_Mtype,addr_preg); 03987 assoc = WN_CreateExp2(OPCODE_make_op(OPR_GT,MTYPE_I4,Pointer_Mtype), 03988 assoc, 03989 WN_Zerocon(Pointer_Mtype)); 03990 cwh_stk_push(assoc,WN_item); 03991 fei_set_dv_hdr_fld(3); 03992 } 03993 } 03994 03995 03996 /*================================================================ 03997 * 03998 * fei_allocate 03999 * 04000 * This routine handles ALLOCATE and DEALLOCATE. Each statement 04001 * has a list of objects to be (de)allocated. Each object gets 04002 * its own dope vector and these are stuffed into an argument 04003 * list and handed to the (de)allocate function. False Parms 04004 * are added to indicate that the DOPE vectors are modified. 04005 * 04006 * When called the stack has 04007 * 1) Arguments to the (DE) ALLOCATE call (count-3 of them) 04008 * 2) The address of the STAT variable, or 0 04009 * 3) The version+count argument (I4) 04010 * 4) The symbol for the routine to call 04011 * 04012 *================================================================ 04013 */ 04014 extern void 04015 fei_allocate(INT32 count) 04016 { 04017 04018 INT num_dopes,i,num_args; 04019 BOOL use_stat; 04020 WN **dopes; 04021 TY_IDX *types; 04022 WN *dope; 04023 WN *wn; 04024 WN *stat,*ver; 04025 ST *routine; 04026 TY_IDX temp_ty; 04027 TY_IDX pty; 04028 ST *temp_st; 04029 INT64 vernum; 04030 WN *call; 04031 char temp_str[40]; 04032 static INT32 temp_name_idx = 0; 04033 04034 num_dopes = count - 3; 04035 dopes = (WN **) malloc(num_dopes*sizeof(WN *)); 04036 types = (TY_IDX *) malloc(num_dopes*sizeof(TY_IDX )); 04037 for (i=0; i < num_dopes; i++) { 04038 types[i] = cwh_stk_get_TY(); 04039 dopes[i] = cwh_expr_operand(NULL); 04040 if (!types[i]) { 04041 /* Try to get the type from the actual address node */ 04042 types[i] = cwh_types_WN_TY(dopes[i],TRUE); 04043 } 04044 } 04045 stat = cwh_expr_operand(NULL); 04046 ver = cwh_expr_operand(NULL); 04047 routine = cwh_stk_pop_ST(); 04048 04049 if (!strcmp(ST_name(routine),"_DEALLOC")) { 04050 use_stat = FALSE; 04051 num_args = num_dopes+1; 04052 } else if (!strcmp(ST_name(routine),"_ALLOCATE")) { 04053 cwh_inline_allocate(dopes,types,num_dopes,stat); 04054 free(dopes); 04055 free(types); 04056 return; 04057 } else { 04058 use_stat = TRUE; 04059 num_args = num_dopes+2; 04060 } 04061 04062 /* Create the call */ 04063 call = WN_Create(OPC_VCALL,num_args); 04064 WN_st_idx(call) = ST_st_idx(routine); 04065 WN_Set_Call_Parm_Ref(call); 04066 WN_Set_Call_Parm_Mod(call); 04067 WN_Set_Call_Does_Mem_Free(call); 04068 04069 /* Make the temp for the argument list to the routine */ 04070 sprintf(temp_str, "%s%d", ".alloctemp.", temp_name_idx); 04071 temp_ty = cwh_types_array_util(1,Be_Type_Tbl(Pointer_Mtype),Pointer_Size, 04072 Pointer_Size*num_dopes+8,temp_str,TRUE); 04073 04074 ARB_HANDLE arb = TY_arb(temp_ty); 04075 Set_ARB_ubnd_val(arb, num_dopes + (8/Pointer_Size)); 04076 Set_ARB_stride_val(arb, Pointer_Size); 04077 04078 sprintf(temp_str, "%s%d", ".alloc", temp_name_idx++); 04079 temp_st = cwh_stab_address_temp_ST(temp_str,temp_ty,FALSE); 04080 Set_ST_base(temp_st, temp_st); 04081 cwh_expr_set_flags(temp_st, f_T_PASSED); 04082 04083 WN_kid0(call) = cwh_intrin_wrap_ref_parm(cwh_addr_address_ST(temp_st, 0),0); 04084 04085 /* Add the stat argument */ 04086 if (use_stat) { 04087 if (WNOPR(stat) == OPR_INTCONST) { 04088 /* No status present, set to a null */ 04089 WN_set_opcode(stat,OPCODE_make_op(OPR_INTCONST,Pointer_Mtype,MTYPE_V)); 04090 stat = cwh_intrin_wrap_value_parm(stat); 04091 } else { 04092 stat = cwh_intrin_wrap_ref_parm(stat,0); 04093 } 04094 WN_kid1(call) = stat; 04095 } 04096 04097 pty = Be_Type_Tbl(Pointer_Mtype); 04098 /* Fill in the temp */ 04099 DevAssert((WN_opcode(ver) == OPC_I8INTCONST),("Expected I8INTCONST for allocate version.")); 04100 if (Pointer_Size == 4) { 04101 # ifdef linux 04102 vernum = WN_const_val(ver) & (0xffffffff); 04103 cwh_block_append(cwh_addr_stid(temp_st,0,pty, 04104 WN_Intconst(Pointer_Mtype,vernum))); 04105 vernum = WN_const_val(ver) >> 32; 04106 cwh_block_append(cwh_addr_stid(temp_st,4,pty, 04107 WN_Intconst(Pointer_Mtype,vernum))); 04108 # else 04109 vernum = WN_const_val(ver) >> 32; 04110 cwh_block_append(cwh_addr_stid(temp_st,0,pty, 04111 WN_Intconst(Pointer_Mtype,vernum))); 04112 vernum = WN_const_val(ver) & (0xffffffff); 04113 cwh_block_append(cwh_addr_stid(temp_st,4,pty, 04114 WN_Intconst(Pointer_Mtype,vernum))); 04115 # endif 04116 WN_DELETE_Tree(ver); 04117 } else { 04118 cwh_block_append(cwh_addr_stid(temp_st,0,pty, ver)); 04119 } 04120 04121 for (i=0; i < num_dopes; i++) { 04122 dope = dopes[i]; 04123 wn = cwh_addr_stid(temp_st, 8 + Pointer_Size*i,pty,WN_COPY_Tree(dope)); 04124 cwh_block_append(wn); 04125 dope = cwh_intrin_wrap_ref_parm(dope,0); 04126 WN_Set_Parm_Dummy(dope); 04127 if (use_stat) { 04128 WN_kid(call,i+2) = dope; 04129 } else { 04130 WN_kid(call,i+1) = dope; 04131 } 04132 } 04133 04134 /* Insert the call */ 04135 04136 cwh_block_append(call); 04137 free (dopes); 04138 free (types); 04139 } 04140 04141 /*=============================================== 04142 * 04143 * cwh_stmt_init_file 04144 * 04145 * Initialize data structures for WHIRL conversion 04146 * at the start of each compilation. The flag says 04147 * -ump was seen on the command line (SGI mp 04148 * directives) and is just convenient here. 04149 * 04150 *=============================================== 04151 */ 04152 04153 extern void 04154 cwh_stmt_init_file(BOOL sgi_mp) 04155 { 04156 cwh_stmt_sgi_mp_flag = sgi_mp ; 04157 cwh_addr_init_target() ; 04158 } 04159 04160 /*=============================================== 04161 * 04162 * cwh_stmt_add_parallel_pragmas 04163 * 04164 * Add the pragmas for CHUNK and MP_SCHEDTYPE 04165 * as specified on the command line 04166 * 04167 *=============================================== 04168 */ 04169 static void 04170 cwh_stmt_add_parallel_pragmas(void) 04171 { 04172 WN *prag; 04173 04174 if (global_chunk_pragma_set) { 04175 prag = WN_CreateXpragma(WN_PRAGMA_CHUNKSIZE, (ST_IDX) 0, 1); 04176 WN_kid0(prag) = WN_Intconst(MTYPE_I4,global_chunk_pragma_value); 04177 cwh_stmt_add_to_preamble(prag,block_pu); 04178 } 04179 04180 if (global_schedtype_pragma_set) { 04181 prag = WN_CreatePragma(WN_PRAGMA_MPSCHEDTYPE, (ST_IDX) NULL, global_schedtype_pragma_val,4); 04182 cwh_stmt_add_to_preamble(prag,block_pu); 04183 } 04184 } 04185 04186 /*=============================================== 04187 * 04188 * cwh_stmt_init_pu 04189 * 04190 * Initialize data structures for WHIRL conversion 04191 * at the start of each PU. 04192 * 04193 *=============================================== 04194 */ 04195 04196 extern void 04197 cwh_stmt_init_pu(ST * st, INT32 lineno) 04198 { 04199 INT16 nkids,i ; 04200 ST **ap ; 04201 04202 cwh_stmt_init_srcpos(lineno); 04203 (void) cwh_block_toggle_debug(FALSE); 04204 04205 nkids = cwh_auxst_num_dummies(st); 04206 ap = cwh_auxst_arglist(st); 04207 04208 (void) cwh_block_new_and_current() ; 04209 04210 WN_tree = WN_CreateEntry (nkids,st,cwh_block_current(), NULL,NULL ); 04211 04212 WN_pragma_pu = WN_kid(WN_tree,nkids); 04213 WN_pragma_ca = WN_kid(WN_tree,nkids+1); 04214 04215 for (i = 0 ; i < nkids ; i ++) 04216 WN_kid(WN_tree,i) = WN_CreateIdname ( 0, *ap++); 04217 04218 WN_Set_Linenum (WN_tree, USRCPOS_srcpos(current_srcpos) ); 04219 WN_Set_Linenum (cwh_block_current(), USRCPOS_srcpos(current_srcpos)); 04220 04221 cwh_stmt_add_parallel_pragmas(); 04222 } 04223 04224 /*=============================================== 04225 * 04226 * cwh_stmt_end_pu 04227 * 04228 * Return the top of the WN tree and clean up. 04229 * Setting the pragma blocks to NULL, means 04230 * additions (from declarations) will be ignored 04231 * until the next PU is set up. 04232 * 04233 *=============================================== 04234 */ 04235 extern WN * 04236 cwh_stmt_end_pu(void) 04237 { 04238 04239 WN_pragma_pu = NULL; 04240 WN_pragma_ca = NULL; 04241 04242 return(WN_tree) ; 04243 } 04244 04245 04246 /*=============================================== 04247 * 04248 * cwh_stmt_postprocess_pu 04249 * 04250 *=============================================== 04251 */ 04252 extern void 04253 cwh_stmt_postprocess_pu(void) 04254 { 04255 04256 if (DEBUG_Conform_Check) { 04257 cwh_stmt_conformance_checks(WN_tree); 04258 } 04259 04260 // if (mp) { 04261 // cwh_stmt_add_local_pragmas(WN_tree); 04262 //} 04263 return; 04264 } 04265 04266 04267 /*=============================================== 04268 * 04269 * cwh_stmt_init_srcpos 04270 * 04271 * Initialize the current line SRCPOS. 04272 * 04273 * The line numbers from the FE occasionally 04274 * refer to an earlier line (eg: a two part 04275 * operation like ALLOC/DEALLOC) so ignore 04276 * the line if < current srcpos. Note that 04277 * nested procedures are processed first. 04278 * 04279 * global_to_local_file returns a pointer into 04280 * the FE's file table, so can avoid cwh_dst_enter_path 04281 * if the pointer was the same as last time. 04282 * 04283 *=============================================== 04284 */ 04285 static void 04286 cwh_stmt_init_srcpos(INT32 lineno) 04287 { 04288 char *file_name; 04289 INT32 local_line_num; 04290 mUINT16 local_file_num; 04291 04292 static char *last_file_name = NULL; 04293 static PU *last_pu = NULL; 04294 04295 if (lineno != 0) { 04296 04297 file_name = global_to_local_file(lineno); 04298 local_line_num = global_to_local_line_number(lineno); 04299 04300 if ((last_file_name != file_name) || 04301 (local_line_num > USRCPOS_linenum(current_srcpos)) || 04302 (last_pu != &(Get_Current_PU()))) { 04303 04304 local_file_num = USRCPOS_filenum(current_srcpos) ; 04305 04306 USRCPOS_clear(current_srcpos); 04307 04308 if (last_file_name != file_name) 04309 USRCPOS_filenum(current_srcpos) = cwh_dst_enter_path(file_name); 04310 else 04311 USRCPOS_filenum(current_srcpos) = local_file_num ; 04312 04313 USRCPOS_linenum(current_srcpos) = local_line_num; 04314 Set_Error_Source (file_name ); 04315 Set_Error_Line(local_line_num); 04316 } 04317 last_file_name = file_name ; 04318 last_pu = &(Get_Current_PU()); 04319 } 04320 } 04321 04322 //================================================================ 04323 //================================================================ 04324 //================================================================ 04325 04326 /*================================================================ 04327 * cwh_stmt_insert_conformance_check(WN **s1, WN **s2, INT ndims1, INT ndims2, INT first_axis, 04328 * WN *stmt, WN *block); 04329 * 04330 * Do the actual work of inserting the conformance check calls. 04331 * 04332 * s1, s2 - arrays of size nodes 04333 * ndims1, ndims2 - number of dimensions to check 04334 * first_axis - the first axis number to report in the event of a failure. If this is 1, for example 04335 * the axes will be numbered 1,2,3.... If it's 0, don't report the axis number. 04336 * stmt, block - where to put the check. Line number comes from stmt. 04337 * 04338 *================================================================*/ 04339 04340 static void 04341 cwh_stmt_insert_conformance_check(WN **s1, WN **s2, INT ndims1, INT ndims2, INT first_axis, 04342 WN *stmt, WN *block) 04343 { 04344 INT i; 04345 WN *eq, *t1,*t2, *gt0, *temp; 04346 BOOL not_all_const = FALSE; 04347 BOOL need_gt0_check; 04348 WN *args[5]; 04349 WN *call; 04350 WN *if_stmt,*ifthenblock; 04351 char * proc_name; 04352 PREG_NUM r1,r2,rgt0; 04353 INT64 lineno; 04354 04355 // quick exit if one or the other ndims is scalar 04356 if (ndims1 == 0 || ndims2 == 0) return; 04357 Is_True(ndims1==ndims2,("conformance check rank mismatch.")); 04358 04359 /* Check for all axes non-zero */ 04360 gt0 = WN_Intconst(MTYPE_I4,1); 04361 for (i=0; i < ndims1; i++) { 04362 t1 = cwh_convert_to_ty(WN_COPY_Tree(s1[i]),MTYPE_I8); 04363 t2 = cwh_convert_to_ty(WN_COPY_Tree(s2[i]),MTYPE_I8); 04364 gt0 = WN_LAND(gt0,WN_LIOR(WN_GT(MTYPE_I8,t1,WN_Zerocon(MTYPE_I8)), 04365 WN_GT(MTYPE_I8,t2,WN_Zerocon(MTYPE_I8)))); 04366 } 04367 04368 need_gt0_check = TRUE; 04369 if (WN_operator(gt0) == OPR_INTCONST) { 04370 if (WN_const_val(gt0) == 0) { 04371 /* Zero sized-array, no check needed */ 04372 WN_DELETE_Tree(gt0); 04373 return; 04374 } else { 04375 WN_DELETE_Tree(gt0); 04376 need_gt0_check = FALSE; 04377 } 04378 } 04379 04380 if (need_gt0_check) { 04381 rgt0 = Create_Preg(MTYPE_I4,Index_To_Str(Save_Str("ccgt0"))); 04382 WN_INSERT_BlockBefore(block,stmt,WN_StidPreg(MTYPE_I4,rgt0,gt0)); 04383 } 04384 04385 for (i=0; i < ndims1; i++) { 04386 t1 = cwh_convert_to_ty(WN_COPY_Tree(s1[i]),MTYPE_I8); 04387 t2 = cwh_convert_to_ty(WN_COPY_Tree(s2[i]),MTYPE_I8); 04388 eq = WN_EQ(MTYPE_I8,WN_COPY_Tree(t1),WN_COPY_Tree(t2)); 04389 04390 if (WN_operator(eq) != OPR_INTCONST || 04391 WN_const_val(eq) == 0) { 04392 // insert the check 04393 04394 lineno = WN_Get_Linenum(stmt); 04395 proc_name = cwh_dst_filename_from_filenum(SRCPOS_filenum(lineno)); 04396 // proc_name = ST_name(Procedure_ST); 04397 args[0] = cwh_intrin_wrap_value_parm(WN_LdaString(proc_name, 0, strlen(proc_name))); 04398 args[1] = cwh_intrin_wrap_value_parm(WN_Intconst(MTYPE_I4, SRCPOS_linenum(lineno))); 04399 if (first_axis != 0) { 04400 args[2] = cwh_intrin_wrap_value_parm(WN_Intconst(MTYPE_I4,ndims1-1-i+first_axis)); 04401 } else { 04402 args[2] = cwh_intrin_wrap_value_parm(WN_Intconst(MTYPE_I4,0)); 04403 } 04404 04405 // Need to stick these in PREGS tp make sure that no array nodes are under the call 04406 r1 = Create_Preg(MTYPE_I8,Index_To_Str(Save_Str("cc1"))); 04407 r2 = Create_Preg(MTYPE_I8,Index_To_Str(Save_Str("cc2"))); 04408 WN_INSERT_BlockBefore(block,stmt,WN_StidPreg(MTYPE_I8,r1,t1)); 04409 WN_INSERT_BlockBefore(block,stmt,WN_StidPreg(MTYPE_I8,r2,t2)); 04410 args[3] = cwh_intrin_wrap_value_parm(WN_LdidPreg(MTYPE_I8,r1)); 04411 args[4] = cwh_intrin_wrap_value_parm(WN_LdidPreg(MTYPE_I8,r2)); 04412 call = WN_Create_Intrinsic(OPR_INTRINSIC_CALL, MTYPE_V, MTYPE_V, 04413 INTRN_F90CONFORM_CHECK, 5, args); 04414 ifthenblock = WN_CreateBlock(); 04415 WN_INSERT_BlockFirst(ifthenblock,call); 04416 if_stmt = WN_NE(MTYPE_I8,WN_LdidPreg(MTYPE_I8,r1),WN_LdidPreg(MTYPE_I8,r2)); 04417 if (need_gt0_check) { 04418 if_stmt = WN_LAND(WN_LdidPreg(MTYPE_I4,rgt0),if_stmt); 04419 } 04420 if_stmt = WN_CreateIf(if_stmt,ifthenblock,WN_CreateBlock()); 04421 WN_INSERT_BlockBefore(block,stmt,if_stmt); 04422 } else { 04423 WN_DELETE_Tree(t1); 04424 WN_DELETE_Tree(t2); 04425 } 04426 WN_DELETE_Tree(eq); 04427 } 04428 } 04429 04430 04431 04432 /*=============================================== 04433 * 04434 * cwh_stmt_conformance_checks_walk (WN *tree, WN *stmt, WN *block, WN ** sizes, INT * ndim) 04435 * 04436 * tree - Tree to check 04437 * stmt, block - The current statement and block before which to put the checks 04438 * sizes - array of sizes (output) of the current tree. The nodes need not be copied before use. 04439 * ndim - dimnesionality of tree (output) 04440 * 04441 * This walks the tree and adds the conformance check information. 04442 * 04443 *================================================================*/ 04444 #define MAX_KIDS 6 04445 04446 static void 04447 cwh_stmt_conformance_checks_walk (WN *tree, WN *stmt, WN *block, WN ** sizes, INT * ndim) 04448 { 04449 OPERATOR op; 04450 WN *node, *nextnode; 04451 04452 WN *ksizes[MAX_KIDS][MAX_ARY_DIMS]; 04453 INT kndims[MAX_KIDS]; 04454 INT i,j,numkids,i_save,numargs; 04455 INT dim; 04456 04457 op = WN_operator(tree); 04458 numkids = WN_kid_count(tree); 04459 if (ndim) *ndim = 0; 04460 04461 if (op == OPR_BLOCK) { 04462 node = WN_first(tree); 04463 while (node) { 04464 nextnode = WN_next(node); /* Because the walk may insert statements */ 04465 cwh_stmt_conformance_checks_walk (node, NULL, tree, NULL, NULL); 04466 node = nextnode; 04467 } 04468 04469 } else if (op == OPR_WHERE) { 04470 /* should be three kids */ 04471 DevAssert((numkids == 3),("Expected WHERE to have three kids.")); 04472 04473 /* first the mask */ 04474 cwh_stmt_conformance_checks_walk (WN_kid(tree,0), tree, block, NULL, NULL); 04475 04476 /* second, the assignment block */ 04477 DevAssert((WN_operator(WN_kid(tree,1)) == OPR_BLOCK),("Expected WHERE to have BLOCK kid 1")); 04478 04479 node = WN_first(WN_kid(tree,1)); 04480 while (node) { 04481 nextnode = WN_next(node); /* Because the walk may insert statements */ 04482 /* send tree and block as insert points */ 04483 cwh_stmt_conformance_checks_walk (node, tree, block, NULL, NULL); 04484 node = nextnode; 04485 } 04486 04487 /* third, is empty block, right now. Send it anyway */ 04488 04489 DevAssert((WN_operator(WN_kid(tree,2)) == OPR_BLOCK),("Expected WHERE to have BLOCK kid 2")); 04490 04491 node = WN_first(WN_kid(tree,2)); 04492 while (node) { 04493 nextnode = WN_next(node); /* Because the walk may insert statements */ 04494 /* send tree and block as insert points */ 04495 cwh_stmt_conformance_checks_walk (node, tree, block, NULL, NULL); 04496 node = nextnode; 04497 } 04498 04499 } else if (op == OPR_ISTORE || op == OPR_MSTORE) { 04500 cwh_stmt_conformance_checks_walk (WN_kid(tree,0), (stmt?stmt:tree), block, ksizes[0], &kndims[0]); 04501 cwh_stmt_conformance_checks_walk (WN_kid(tree,1), (stmt?stmt:tree), block, ksizes[1], &kndims[1]); 04502 cwh_stmt_insert_conformance_check(ksizes[0],ksizes[1],kndims[0],kndims[1],1,(stmt?stmt:tree),block); 04503 if (sizes) { 04504 *ndim = kndims[0]; 04505 for (i=0; i < kndims[0]; i++) { 04506 sizes[i] = ksizes[0][i]; 04507 } 04508 } else { 04509 for (i=0; i < kndims[0]; i++) { 04510 WN_DELETE_Tree(ksizes[0][i]); 04511 } 04512 } 04513 for (i=0; i < kndims[1]; i++) { 04514 WN_DELETE_Tree(ksizes[1][i]); 04515 } 04516 04517 } else if (op == OPR_INTRINSIC_CALL && WN_intrinsic(tree) == INTRN_CASSIGNSTMT) { 04518 // Character assignment 04519 cwh_stmt_conformance_checks_walk (WN_kid(tree,0), (stmt?stmt:tree), block, ksizes[0], &kndims[0]); 04520 cwh_stmt_conformance_checks_walk (WN_kid(tree,1), (stmt?stmt:tree), block, ksizes[1], &kndims[1]); 04521 cwh_stmt_conformance_checks_walk (WN_kid(tree,2), (stmt?stmt:tree), block, NULL, NULL); 04522 cwh_stmt_conformance_checks_walk (WN_kid(tree,3), (stmt?stmt:tree), block, NULL, NULL); 04523 cwh_stmt_insert_conformance_check(ksizes[0],ksizes[1],kndims[0],kndims[1],1,(stmt?stmt:tree),block); 04524 if (sizes) { 04525 *ndim = kndims[0]; 04526 for (i=0; i < kndims[0]; i++) { 04527 sizes[i] = ksizes[0][i]; 04528 } 04529 } else { 04530 for (i=0; i < kndims[0]; i++) { 04531 WN_DELETE_Tree(ksizes[0][i]); 04532 } 04533 } 04534 for (i=0; i < kndims[1]; i++) { 04535 WN_DELETE_Tree(ksizes[1][i]); 04536 } 04537 04538 } else if (op == OPR_INTRINSIC_CALL && WN_intrinsic(tree) == INTRN_CONCATEXPR) { 04539 // CONCAT 04540 cwh_stmt_conformance_checks_walk (WN_kid(tree,0), (stmt?stmt:tree), block, ksizes[0], &kndims[0]); 04541 cwh_stmt_conformance_checks_walk (WN_kid(tree,1), (stmt?stmt:tree), block, NULL, NULL); 04542 04543 numargs = (numkids - 2)/2; 04544 for (i=0; i < numargs; i++) { 04545 cwh_stmt_conformance_checks_walk (WN_kid(tree,i+2), (stmt?stmt:tree), block, ksizes[1], &kndims[1]); 04546 cwh_stmt_conformance_checks_walk (WN_kid(tree,i+2+numargs), (stmt?stmt:tree), block, NULL, NULL); 04547 cwh_stmt_insert_conformance_check(ksizes[0],ksizes[1],kndims[0],kndims[1],1,(stmt?stmt:tree),block); 04548 for (j=0; j < kndims[1]; j++) { 04549 WN_DELETE_Tree(ksizes[1][j]); 04550 } 04551 } 04552 04553 if (sizes) { 04554 *ndim = kndims[0]; 04555 for (i=0; i < kndims[0]; i++) { 04556 sizes[i] = ksizes[0][i]; 04557 } 04558 } else { 04559 for (i=0; i < kndims[0]; i++) { 04560 WN_DELETE_Tree(ksizes[0][i]); 04561 } 04562 } 04563 04564 } else if (OPERATOR_is_stmt(op) || OPERATOR_is_scf(op)) { 04565 for (i=0; i < numkids; i++) { 04566 cwh_stmt_conformance_checks_walk (WN_kid(tree,i), (stmt?stmt:tree), block, NULL, NULL); 04567 } 04568 04569 } else { 04570 // Expression nodes 04571 switch (op) { 04572 case OPR_ARRAYEXP: 04573 case OPR_ARRSECTION: 04574 case OPR_ARRAY: 04575 case OPR_SRCTRIPLET: 04576 for (i=0; i < numkids; i++) { 04577 cwh_stmt_conformance_checks_walk (WN_kid(tree,i), stmt, block, NULL, NULL); 04578 } 04579 #if 0 04580 if (sizes) { 04581 F90_Size_Walk(tree,ndim,sizes); 04582 } 04583 #endif 04584 break; 04585 04586 default: 04587 // Make sure all arguments are the same shape 04588 if (op == OPR_INTRINSIC_OP && F90_Is_Transformational(WN_intrinsic(tree))) { 04589 // Special for transformationals 04590 switch (WN_intrinsic(tree)) { 04591 // No specific checking needed 04592 default: 04593 case INTRN_SPREAD: 04594 case INTRN_TRANSPOSE: 04595 case INTRN_ALL: 04596 case INTRN_ANY: 04597 case INTRN_COUNT: 04598 case INTRN_RESHAPE: // we don't generate this yet, so we don't need to check it 04599 for (i=0; i < numkids; i++) { 04600 cwh_stmt_conformance_checks_walk (WN_kid(tree,0), stmt, block, NULL, NULL); 04601 } 04602 if (sizes) { 04603 F90_Size_Walk(tree,ndim,sizes); 04604 } 04605 break; 04606 04607 case INTRN_MATMUL: 04608 case INTRN_DOT_PRODUCT: 04609 cwh_stmt_conformance_checks_walk (WN_kid(tree,0), stmt, block, ksizes[0], &kndims[0]); 04610 cwh_stmt_conformance_checks_walk (WN_kid(tree,1), stmt, block, ksizes[1], &kndims[1]); 04611 if (kndims[0] == 2 && kndims[1] == 2) { 04612 cwh_stmt_insert_conformance_check(&ksizes[0][0],&ksizes[1][1],1,1,0,stmt,block); 04613 WN_DELETE_Tree(ksizes[0][0]); 04614 WN_DELETE_Tree(ksizes[1][1]); 04615 if (sizes) { 04616 sizes[1] = ksizes[0][1]; 04617 sizes[0] = ksizes[1][0]; 04618 *ndim = 2; 04619 } 04620 } else if (kndims[0] == 2 && kndims[1] == 1) { 04621 cwh_stmt_insert_conformance_check(&ksizes[0][0],&ksizes[1][0],1,1,0,stmt,block); 04622 WN_DELETE_Tree(ksizes[0][0]); 04623 WN_DELETE_Tree(ksizes[1][0]); 04624 if (sizes) { 04625 sizes[0] = ksizes[0][1]; 04626 *ndim = 1; 04627 } 04628 } else if (kndims[0] == 1 && kndims[1] == 2) { 04629 cwh_stmt_insert_conformance_check(&ksizes[0][0],&ksizes[1][1],1,1,0,stmt,block); 04630 WN_DELETE_Tree(ksizes[0][0]); 04631 WN_DELETE_Tree(ksizes[1][1]); 04632 if (sizes) { 04633 sizes[0] = ksizes[1][0]; 04634 *ndim = 1; 04635 } 04636 } else { 04637 // 1,1 means dot_product 04638 cwh_stmt_insert_conformance_check(&ksizes[0][0],&ksizes[1][0],1,1,1,stmt,block); 04639 WN_DELETE_Tree(ksizes[0][0]); 04640 WN_DELETE_Tree(ksizes[1][0]); 04641 } 04642 break; 04643 04644 case INTRN_PRODUCT: 04645 case INTRN_SUM: 04646 case INTRN_MAXVAL: 04647 case INTRN_MINVAL: 04648 case INTRN_MAXLOC: 04649 case INTRN_MINLOC: 04650 cwh_stmt_conformance_checks_walk (WN_kid(tree,0), stmt, block, ksizes[0], &kndims[0]); 04651 cwh_stmt_conformance_checks_walk (WN_kid(tree,2), stmt, block, ksizes[1], &kndims[1]); 04652 cwh_stmt_insert_conformance_check(ksizes[0],ksizes[1],kndims[0],kndims[1],1,stmt,block); 04653 for (i=0; i < kndims[0]; i++) { 04654 WN_DELETE_Tree(ksizes[0][i]); 04655 } 04656 for (i=0; i < kndims[1]; i++) { 04657 WN_DELETE_Tree(ksizes[1][i]); 04658 } 04659 if (sizes) { 04660 F90_Size_Walk(tree,ndim,sizes); 04661 } 04662 break; 04663 04664 case INTRN_CSHIFT: 04665 cwh_stmt_conformance_checks_walk (WN_kid(tree,0), stmt, block, ksizes[0], &kndims[0]); 04666 cwh_stmt_conformance_checks_walk (WN_kid(tree,1), stmt, block, ksizes[1], &kndims[1]); 04667 dim = F90_Get_Dim(WN_kid(tree,2))-1; 04668 // check for conformance between the shift argument and the array argument 04669 // less the dim dimension 04670 if (dim >= 0) { 04671 for (i=0,j=0; i < kndims[0]; i++) { 04672 if (i != kndims[0]-1-dim) { 04673 ksizes[2][j] = ksizes[0][i]; 04674 ++j; 04675 } 04676 } 04677 kndims[2] = kndims[0] - 1; 04678 cwh_stmt_insert_conformance_check(ksizes[2],ksizes[1],kndims[2],kndims[1],0,stmt,block); 04679 } 04680 if (sizes) { 04681 *ndim = kndims[0]; 04682 for (i=0; i < kndims[0]; i++) { 04683 sizes[i] = ksizes[0][i]; 04684 } 04685 } else { 04686 for (i=0; i < kndims[0]; i++) { 04687 WN_DELETE_Tree(ksizes[0][i]); 04688 } 04689 } 04690 for (i=0; i < kndims[1]; i++) { 04691 WN_DELETE_Tree(ksizes[1][i]); 04692 } 04693 break; 04694 04695 case INTRN_EOSHIFT: 04696 cwh_stmt_conformance_checks_walk (WN_kid(tree,0), stmt, block, ksizes[0], &kndims[0]); 04697 cwh_stmt_conformance_checks_walk (WN_kid(tree,1), stmt, block, ksizes[1], &kndims[1]); 04698 cwh_stmt_conformance_checks_walk (WN_kid(tree,2), stmt, block, ksizes[2], &kndims[2]); 04699 dim = F90_Get_Dim(WN_kid(tree,3))-1; 04700 // check for conformance between the shift and boundary arguments and the array argument 04701 // less the dim dimension 04702 if (dim >= 0) { 04703 for (i=0,j=0; i < kndims[0]; i++) { 04704 if (i != kndims[0]-1-dim) { 04705 ksizes[3][j] = ksizes[0][i]; 04706 ++j; 04707 } 04708 } 04709 kndims[3] = kndims[0] - 1; 04710 cwh_stmt_insert_conformance_check(ksizes[3],ksizes[1],kndims[3],kndims[1],0,stmt,block); 04711 cwh_stmt_insert_conformance_check(ksizes[3],ksizes[2],kndims[3],kndims[2],0,stmt,block); 04712 } 04713 if (sizes) { 04714 *ndim = kndims[0]; 04715 for (i=0; i < kndims[0]; i++) { 04716 sizes[i] = ksizes[0][i]; 04717 } 04718 } else { 04719 for (i=0; i < kndims[0]; i++) { 04720 WN_DELETE_Tree(ksizes[0][i]); 04721 } 04722 } 04723 for (i=0; i < kndims[1]; i++) { 04724 WN_DELETE_Tree(ksizes[1][i]); 04725 } 04726 for (i=0; i < kndims[2]; i++) { 04727 WN_DELETE_Tree(ksizes[2][i]); 04728 } 04729 break; 04730 04731 case INTRN_PACK: 04732 cwh_stmt_conformance_checks_walk (WN_kid(tree,0), stmt, block, ksizes[0], &kndims[0]); 04733 cwh_stmt_conformance_checks_walk (WN_kid(tree,1), stmt, block, ksizes[1], &kndims[1]); 04734 cwh_stmt_conformance_checks_walk (WN_kid(tree,2), stmt, block, sizes, ndim); 04735 cwh_stmt_insert_conformance_check(ksizes[0],ksizes[1],kndims[0],kndims[1],1,stmt,block); 04736 for (i=0; i < kndims[0]; i++) { 04737 WN_DELETE_Tree(ksizes[0][i]); 04738 } 04739 for (i=0; i < kndims[1]; i++) { 04740 WN_DELETE_Tree(ksizes[1][i]); 04741 } 04742 break; 04743 04744 case INTRN_UNPACK: 04745 cwh_stmt_conformance_checks_walk (WN_kid(tree,0), stmt, block, NULL, NULL); 04746 cwh_stmt_conformance_checks_walk (WN_kid(tree,1), stmt, block, ksizes[0], &kndims[0]); 04747 cwh_stmt_conformance_checks_walk (WN_kid(tree,2), stmt, block, ksizes[1], &kndims[1]); 04748 cwh_stmt_insert_conformance_check(ksizes[0],ksizes[1],kndims[0],kndims[1],1,stmt,block); 04749 // copy sizes and cleanup 04750 if (sizes) { 04751 *ndim = kndims[0]; 04752 for (i=0; i < kndims[0]; i++) { 04753 sizes[i] = ksizes[0][i]; 04754 } 04755 } else { 04756 for (i=0; i < kndims[0]; i++) { 04757 WN_DELETE_Tree(ksizes[0][i]); 04758 } 04759 } 04760 for (i=0; i < kndims[1]; i++) { 04761 WN_DELETE_Tree(ksizes[1][i]); 04762 } 04763 break; 04764 04765 } // intrinsics switch 04766 04767 break; 04768 } // Transformational intrinsics 04769 04770 if (numkids == 0) { 04771 break; 04772 } 04773 if (numkids == 1) { 04774 cwh_stmt_conformance_checks_walk (WN_kid(tree,0), stmt, block, sizes, ndim); 04775 break; 04776 } 04777 04778 // More than one kid 04779 if (numkids > MAX_KIDS) break; 04780 for (i=0; i < numkids; i++) { 04781 cwh_stmt_conformance_checks_walk (WN_kid(tree,i), stmt, block, 04782 ksizes[i], &kndims[i]); 04783 } 04784 for (i=0; i < numkids; i++) { 04785 for (j = i+1; j < numkids; j++) { 04786 cwh_stmt_insert_conformance_check(ksizes[i],ksizes[j],kndims[i],kndims[j],1,stmt,block); 04787 } 04788 } 04789 04790 /* Figure out which ones to save */ 04791 i_save = -1; 04792 if (sizes) { 04793 for (i=0; i < numkids; i++) { 04794 if (kndims[i] > *ndim) { 04795 i_save = i; 04796 *ndim = kndims[i]; 04797 for (j = 0; j < kndims[i]; j++) { 04798 sizes[j] = ksizes[i][j]; 04799 } 04800 } 04801 } 04802 } 04803 04804 /* Clean up the rest */ 04805 for (i=0; i < numkids; i++) { 04806 if (i_save != i) { 04807 for (j = 0; j < kndims[i]; j++) { 04808 WN_DELETE_Tree(ksizes[i][j]); 04809 } 04810 } 04811 } 04812 break; 04813 } // expressions switch 04814 } // expressions 04815 return; 04816 } 04817 04818 04819 /*=============================================== 04820 * 04821 * cwh_stmt_conformance_checks (WN *tree) 04822 * 04823 * Adds the conformance checks for array operations to the tree. This 04824 * is normally added only with bounds checking 04825 * 04826 *================================================================*/ 04827 04828 static void 04829 cwh_stmt_conformance_checks(WN *tree) 04830 { 04831 cwh_stmt_conformance_checks_walk(tree,NULL,NULL,NULL,NULL); 04832 } 04833 04834 /*============================================ 04835 * fei_use 04836 * 04837 *===============================================*/ 04838 04839 extern void 04840 fei_use(INT32 rename_only_num, INT32 onlyPredicate) 04841 { 04842 OPCODE opc; 04843 ST * st ; 04844 WN * wn ; 04845 int i ; 04846 04847 // cwh_stk_pop_whatever() ; 04848 04849 st = cwh_stk_pop_ST(); 04850 04851 if (onlyPredicate) 04852 // we use the MTYPE_B rtype to signal the presence of 04853 // the ONLY predicate 04854 opc = OPCODE_make_op(OPR_USE,MTYPE_B,MTYPE_V); 04855 else 04856 opc = OPCODE_make_op(OPR_USE,MTYPE_V,MTYPE_V); 04857 04858 wn = WN_Create(opc,rename_only_num); 04859 04860 WN_st_idx(wn) = ST_st_idx(st); 04861 for (i=rename_only_num-1; i>=0; i--) 04862 { 04863 st = cwh_stk_pop_ST(); 04864 WN_kid(wn,i) = WN_CreateIdname ( 0, st); 04865 } 04866 cwh_block_append(wn); 04867 return; 04868 } 04869 //***********************************************************// 04870 04871 extern void 04872 fei_nullify(INT32 listnum) 04873 { 04874 OPCODE opc; 04875 ST * st ; 04876 WN * wn ; 04877 WN * wa ; 04878 int i ; 04879 FLD_det det ; 04880 04881 opc = OPCODE_make_op(OPR_NULLIFY,MTYPE_V,MTYPE_V); 04882 wn = WN_Create(opc,listnum); 04883 04884 for (i=listnum-1; i>=0; i--) 04885 { 04886 04887 switch(cwh_stk_get_class()) { 04888 case FLD_item: 04889 case ST_item: 04890 case ST_item_whole_array: 04891 wa = cwh_expr_operand(NULL); 04892 break; 04893 #if 0 04894 st = cwh_stk_pop_ST(); 04895 wa = WN_CreateIdname ( 0, st); 04896 break; 04897 #endif 04898 case WN_item: 04899 wa = cwh_stk_pop_WN(); 04900 break; 04901 #if 0 04902 case FLD_item: 04903 det = cwh_addr_offset(); 04904 if (cwh_stk_get_class() == ST_item || 04905 cwh_stk_get_class() == ST_item_whole_array) { 04906 st = cwh_stk_pop_ST(); 04907 wa = cwh_addr_ldid(st,det.off,det.type); 04908 } else { 04909 wa = cwh_stk_pop_WHIRL(); 04910 wa = cwh_expr_bincalc(OPR_ADD,wa,WN_Intconst(Pointer_Mtype,det.off)); 04911 wa = F90_Wrap_ARREXP(wa); 04912 } 04913 break; 04914 #endif 04915 case STR_item: 04916 cwh_stk_pop_STR(); 04917 cwh_stk_pop_WN(); 04918 cwh_stk_get_TY(); 04919 wa = cwh_stk_pop_WN(); 04920 wa = cwh_expr_extract_arrayexp(wa,DELETE_ARRAYEXP_WN); 04921 break; 04922 04923 default: 04924 cwh_stk_pop_whatever() ; 04925 wa = NULL; 04926 break; 04927 } 04928 04929 WN_kid(wn,i) = wa ; 04930 } 04931 cwh_block_append(wn); 04932 return; 04933 } 04934 04935 //****************************************************************// 04936 extern void 04937 fei_gen_func_entry(INTPTR sym_idx) 04938 { 04939 INT16 nkids,i ; 04940 ST **ap ; 04941 WN *wn; 04942 04943 STB_pkt *p ; 04944 04945 if(sym_idx) { 04946 04947 p = cast_to_STB(sym_idx); 04948 DevAssert((p->form == is_ST),("Odd object ref")); 04949 04950 ST * st = cast_to_ST(p->item); 04951 DevAssert((st),("null st")); 04952 04953 04954 (void) cwh_block_toggle_debug(FALSE); 04955 04956 nkids = cwh_auxst_num_dummies(st); 04957 ap = cwh_auxst_arglist(st); 04958 04959 wn = WN_Create (OPC_FUNC_ENTRY, nkids); 04960 WN_entry_name(wn) = ST_st_idx (st); 04961 04962 for (i = 0 ; i < nkids ; i ++) 04963 WN_kid(wn,i) = WN_CreateIdname ( 0, *ap++); 04964 04965 cwh_stk_push(wn,WN_item); 04966 04967 } 04968 } 04969 04970 04971 extern void 04972 fei_array_construct(INT32 nlist,TYPE ty) 04973 { 04974 OPCODE opc; 04975 WN *wn; 04976 WN *par; 04977 WN ** lists; 04978 TY_IDX ty_idx; 04979 int i; 04980 04981 lists = (WN **) malloc(nlist*sizeof(WN *)); 04982 ty_idx = cast_to_TY(t_TY(ty)); 04983 04984 for (i=nlist-1;i>=0;i--) { 04985 switch(cwh_stk_get_class()) { 04986 case STR_item: 04987 cwh_stk_pop_STR(); 04988 lists[i] =cwh_stk_pop_WN(); 04989 break ; 04990 04991 case ADDR_item: 04992 lists[i] = cwh_stk_pop_ADDR(); 04993 break; 04994 04995 case WN_item: 04996 case WN_item_whole_array: 04997 04998 lists[i]= cwh_stk_pop_WN(); 04999 break ; 05000 05001 case ST_item: 05002 case ST_item_whole_array: 05003 case FLD_item: 05004 lists[i] = cwh_expr_operand(NULL); 05005 break; 05006 05007 case DEREF_item: 05008 lists[i] = cwh_stk_pop_DEREF(); 05009 break; 05010 05011 default: 05012 DevAssert((0),("Odd call actual")) ; 05013 } 05014 } 05015 05016 opc = OPCODE_make_op(OPR_ARRAY_CONSTRUCT,TY_mtype(ty_idx),MTYPE_V); 05017 par = WN_Create(opc,nlist); 05018 for (i=0; i < nlist; i++) 05019 WN_kid(par,i) = lists[i]; 05020 05021 cwh_stk_push(par,WN_item) ; 05022 05023 } 05024 05025 extern void 05026 fei_noio_implied_do() 05027 { 05028 OPCODE opc; 05029 WN *wn; 05030 WN *wa; 05031 WN ** kids; 05032 INT32 numkids = 5; 05033 INT32 i; 05034 05035 kids = (WN **)malloc(numkids*sizeof(WN *)); 05036 05037 for (i=numkids-1;i>=0;i--) { 05038 switch(cwh_stk_get_class()) { 05039 case STR_item: 05040 cwh_stk_pop_STR(); 05041 05042 wa =cwh_stk_pop_WN(); 05043 05044 if (cwh_stk_get_class()==ST_item) { 05045 wa = cwh_expr_operand(NULL); 05046 kids[i] = wa; 05047 }else 05048 if (cwh_stk_get_class()==WN_item) 05049 kids[i] =cwh_stk_pop_WN(); 05050 05051 break ; 05052 05053 case ADDR_item: 05054 kids[i] = cwh_stk_pop_ADDR(); 05055 break; 05056 05057 case FLD_item: 05058 case ST_item: 05059 case ST_item_whole_array: 05060 wa = cwh_expr_operand(NULL); 05061 kids[i] = wa; 05062 break ; 05063 05064 case WN_item: 05065 case WN_item_whole_array: 05066 05067 kids[i]= cwh_stk_pop_WN(); 05068 break ; 05069 default: 05070 DevAssert((0),("Odd call actual")) ; 05071 } 05072 } 05073 05074 05075 opc = OPCODE_make_op(OPR_IMPLIED_DO,MTYPE_V,MTYPE_V); 05076 05077 wn = WN_Create(opc,5); 05078 05079 for (i=0; i<=numkids-1; i++) 05080 WN_kid(wn,i) = kids[i]; 05081 05082 05083 cwh_stk_push(wn,WN_item) ; 05084 05085 }