Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
00001 /* 00002 00003 Copyright (C) 2000, 2001 Silicon Graphics, Inc. All Rights Reserved. 00004 00005 This program is free software; you can redistribute it and/or modify it 00006 under the terms of version 2 of the GNU General Public License as 00007 published by the Free Software Foundation. 00008 00009 This program is distributed in the hope that it would be useful, but 00010 WITHOUT ANY WARRANTY; without even the implied warranty of 00011 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00012 00013 Further, this software is distributed without any warranty that it is 00014 free of the rightful claim of any third person regarding infringement 00015 or the like. Any license provided herein, whether implied or 00016 otherwise, applies only to this software file. Patent licenses, if 00017 any, provided herein do not apply to combinations of this program with 00018 other software, or any other product whatsoever. 00019 00020 You should have received a copy of the GNU General Public License along 00021 with this program; if not, write the Free Software Foundation, Inc., 59 00022 Temple Place - Suite 330, Boston MA 02111-1307, USA. 00023 00024 Contact information: Silicon Graphics, Inc., 1600 Amphitheatre Pky, 00025 Mountain View, CA 94043, or: 00026 00027 http://www.sgi.com 00028 00029 For further information regarding this notice, see: 00030 00031 http://oss.sgi.com/projects/GenInfo/NoticeExplan 00032 00033 */ 00034 00035 00036 /* ==================================================================== 00037 * ==================================================================== 00038 * 00039 * 00040 * Revision history: 00041 * dd-mmm-95 - Original Version 00042 * 00043 * Description: contains routines for expressions and conversions. 00044 * Entry points from PDGCS layer are those for 00045 * unary & binary operations eg: 00046 * fei_plus,fei_bneg, fei_max.. 00047 * 00048 * The Cray IR doesn't contain explicit conversions 00049 * so each operand is checked, and OPC_CVRTLs sprinkled 00050 * around. Small operands - I1,U2 etc are also converted 00051 * to the minumun WH sizes I4,U4. 00052 * 00053 * The source of operands is the expression stack, via 00054 * the routine cwh_expr_operand. Usually that's where 00055 * the result goes too. 00056 * 00057 * ==================================================================== 00058 * ==================================================================== 00059 */ 00060 00061 static char *source_file = __FILE__; 00062 00063 #ifdef _KEEP_RCS_ID 00064 #endif /* _KEEP_RCS_ID */ 00065 00066 00067 /* sgi includes */ 00068 00069 #include "defs.h" 00070 #include "glob.h" 00071 #include "stab.h" 00072 #include "strtab.h" 00073 #include "errors.h" 00074 #include "config_targ.h" 00075 #include "targ_const.h" 00076 #include "wn.h" 00077 #include "wn_util.h" 00078 #include "const.h" 00079 #include "f90_utils.h" 00080 #include "sgi_cmd_line.h" 00081 00082 /* Cray includes */ 00083 00084 #include "i_cvrt.h" 00085 00086 /* conversion includes */ 00087 00088 #include "cwh_defines.h" 00089 #include "cwh_addr.h" 00090 #include "cwh_expr.h" 00091 #include "cwh_block.h" 00092 #include "cwh_types.h" 00093 #include "cwh_preg.h" 00094 #include "cwh_stab.h" 00095 #include "cwh_auxst.h" 00096 #include "cwh_stmt.h" 00097 #include "cwh_stk.h" 00098 #include "cwh_expr.h" 00099 #include "cwh_intrin.h" 00100 #include "cwh_preg.h" 00101 00102 static void cwh_expr_binop(OPERATOR op, TY_IDX result_ty) ; 00103 static void cwh_expr_unop(OPERATOR op,TY_IDX result_ty) ; 00104 static WN * cwh_expr_compare_char(OPERATOR op, TY_IDX ty) ; 00105 00106 00107 /*================================================================ 00108 * 00109 * cwh_expr_extract_arrayexp 00110 * 00111 * Pulls an ARRAYEXP off the top of wn. If *arrayexp is non-null, 00112 * delete the ARRAYEXP. IF *arrayexp is NULL, return the ARRAYEXP in it. 00113 * If arrayexp == 1, then delete the arrayexp. 00114 * 00115 *================================================================ 00116 */ 00117 extern WN * 00118 cwh_expr_extract_arrayexp(WN *wn, WN **arrayexp) 00119 { 00120 WN * ae; 00121 INT i; 00122 if (Full_arrayexp) { 00123 if (WNOPR(wn) == OPR_ARRAYEXP && arrayexp != NULL) { 00124 ae = wn; 00125 wn = WN_kid0(wn); 00126 00127 /* Check to see if we should delete it */ 00128 if (arrayexp != DELETE_ARRAYEXP_WN && *arrayexp == NULL) { 00129 *arrayexp = ae; 00130 } else { 00131 for (i = 1; i < WN_kid_count(ae); i++) { 00132 WN_DELETE_Tree(WN_kid(ae,i)); 00133 } 00134 WN_Delete(ae); 00135 } 00136 } 00137 } 00138 00139 return (wn); 00140 } 00141 00142 /*================================================================ 00143 * 00144 * cwh_expr_restore_arrayexp 00145 * 00146 * Puts an ARRAYEXP back on top of wn. If arrayexp is non-null, 00147 * put it on top of the expression. 00148 * 00149 *================================================================ 00150 */ 00151 extern WN * 00152 cwh_expr_restore_arrayexp(WN *wn, WN *arrayexp) 00153 { 00154 OPCODE opc; 00155 00156 if (Full_arrayexp && arrayexp) { 00157 WN_kid0(arrayexp) = wn; 00158 opc = cwh_make_typed_opcode(OPR_ARRAYEXP,WN_rtype(wn),MTYPE_V); 00159 WN_set_opcode(arrayexp,opc); 00160 return (arrayexp); 00161 } else { 00162 return (wn); 00163 } 00164 } 00165 00166 /*================================================================ 00167 * 00168 * cwh_wrap_cvtl 00169 * 00170 * Wrap a CVTL around an expressions for small types 00171 * 00172 *================================================================== 00173 */ 00174 extern WN * 00175 cwh_wrap_cvtl(WN * wn, TYPE_ID ty) 00176 { 00177 return F90_wrap_cvtl(wn,ty); 00178 } 00179 00180 /*================================================================ 00181 * 00182 * cwh_convert_to_ty 00183 * 00184 * Convert a node to a new type. Needed because we don't 00185 * have explicit converts in the trees from the Cray IR. It's also 00186 * a useful routine to have around. 00187 * 00188 *================================================================ 00189 */ 00190 extern WN * 00191 cwh_convert_to_ty(WN * wn, TYPE_ID ty) 00192 { 00193 TYPE_ID old_ty,real_ty,new_real_ty; 00194 OPCODE cvt_op; 00195 OPCODE realpart,imagpart; 00196 WN *r; 00197 WN *ri,*rr; 00198 00199 old_ty = WNRTY(wn); 00200 if (old_ty == ty) return (wn); 00201 00202 if (old_ty == MTYPE_I1 || old_ty == MTYPE_I2) { 00203 /* treat as it it were an I4 */ 00204 old_ty = MTYPE_I4; 00205 } 00206 00207 r = wn; 00208 cvt_op = OPCODE_UNKNOWN; 00209 00210 00211 /* Special case for TAS nodes */ 00212 if (WNOPR(wn) == OPR_TAS) { 00213 WN_set_opcode(wn,OPCODE_make_op(OPR_TAS,ty,MTYPE_V)); 00214 return (wn); 00215 } 00216 00217 if (MTYPE_is_complex(old_ty)) { 00218 real_ty = Mtype_complex_to_real(old_ty); 00219 realpart = OPCODE_make_op(OPR_REALPART,real_ty,MTYPE_V); 00220 imagpart = OPCODE_make_op(OPR_IMAGPART,real_ty,MTYPE_V); 00221 00222 /* complex to non-complex */ 00223 00224 if (!MTYPE_is_complex(ty)) { 00225 r = WN_CreateExp1(realpart,r); 00226 r = cwh_convert_to_ty(r,ty); 00227 00228 } else { /* complex to complex */ 00229 00230 new_real_ty = Mtype_complex_to_real(ty); 00231 rr = WN_CreateExp1(realpart,WN_COPY_Tree(r)); 00232 rr = cwh_convert_to_ty(rr,new_real_ty); 00233 ri = WN_CreateExp1(imagpart,r); 00234 ri = cwh_convert_to_ty(ri,new_real_ty); 00235 r = WN_CreateExp2(OPCODE_make_op(OPR_COMPLEX,ty,MTYPE_V),rr,ri); 00236 } 00237 return (r); 00238 00239 } else if (MTYPE_is_complex(ty)) { 00240 real_ty = Mtype_complex_to_real(ty); 00241 cvt_op = OPCODE_make_op(OPR_COMPLEX,ty,MTYPE_V); 00242 r = cwh_convert_to_ty(r,real_ty); 00243 r = WN_CreateExp2(cvt_op,r,Make_Zerocon(real_ty)); 00244 return (r); 00245 } 00246 00247 00248 if (ty == MTYPE_I1 || ty == MTYPE_I2) { 00249 /* First convert to I4, then do a CVTL */ 00250 r = cwh_convert_to_ty(wn,MTYPE_I4); 00251 r = cwh_wrap_cvtl(r,ty); 00252 return (r); 00253 } 00254 00255 if (ty == MTYPE_U1 || ty == MTYPE_U2) { 00256 /* First convert to I4, then do a CVTL */ 00257 r = cwh_convert_to_ty(wn,MTYPE_U4); 00258 r = cwh_wrap_cvtl(r,ty); 00259 return (r); 00260 } 00261 00262 00263 if (MTYPE_is_float(ty)) { 00264 /* Converts to float */ 00265 cvt_op = OPCODE_make_op(OPR_CVT,ty,old_ty); 00266 } else if (MTYPE_is_float(old_ty)) { 00267 /* Converts from float to integer */ 00268 cvt_op = OPCODE_make_op(OPR_TRUNC,ty,old_ty); 00269 } else { 00270 /* Integral to integral */ 00271 if (MTYPE_size_reg(ty) != MTYPE_size_reg(old_ty)) { 00272 cvt_op = OPCODE_make_op(OPR_CVT,ty,old_ty); 00273 } 00274 } 00275 00276 /* See if there is a single op to do the conversion */ 00277 if (cvt_op != 0) { 00278 r = WN_CreateExp1(cvt_op,r); 00279 } 00280 00281 return (r); 00282 } 00283 00284 /*=============================================== 00285 * 00286 * cwh_get_highest_type 00287 * 00288 * Utility routine for type conversions, etc. 00289 * 00290 * Takes two operands, and converts them so that both 00291 * are of the "greater" (in the fortran sense) type. 00292 * 00293 *=============================================== 00294 */ 00295 extern TYPE_ID 00296 cwh_get_highest_type(WN *lhs, WN *rhs) 00297 { 00298 TYPE_ID t1,t2,r; 00299 t1 = WN_rtype(lhs); 00300 t2 = WN_rtype(rhs); 00301 00302 /* Types are the same, nothing to do */ 00303 if (t1 == t2) return (t1); 00304 00305 if (MTYPE_is_complex(t1) && !MTYPE_is_complex(t2)) { 00306 t1 = Mtype_complex_to_real(t1); 00307 if (MTYPE_type_order(t2) > MTYPE_type_order(t1)) { 00308 r = t2; 00309 } else { 00310 r = t1; 00311 } 00312 /* Convert r to complex */ 00313 switch (r) { 00314 case MTYPE_F4: r = MTYPE_C4; break; 00315 case MTYPE_F8: r = MTYPE_C8; break; 00316 case MTYPE_FQ: r = MTYPE_CQ; break; 00317 } 00318 } else if (MTYPE_is_complex(t2) && !MTYPE_is_complex(t1)) { 00319 t2 = Mtype_complex_to_real(t2); 00320 if (MTYPE_type_order(t2) > MTYPE_type_order(t1)) { 00321 r = t2; 00322 } else { 00323 r = t1; 00324 } 00325 /* Convert r to complex */ 00326 switch (r) { 00327 case MTYPE_F4: r = MTYPE_C4; break; 00328 case MTYPE_F8: r = MTYPE_C8; break; 00329 case MTYPE_FQ: r = MTYPE_CQ; break; 00330 } 00331 } else { 00332 /* No complexes, return the greatest in type order */ 00333 if (MTYPE_type_order(t2) > MTYPE_type_order(t1)) { 00334 r = t2; 00335 } else { 00336 r = t1; 00337 } 00338 } 00339 return (r); 00340 } 00341 00342 /*=============================================== 00343 * 00344 * cwh_get_typed_operand 00345 * 00346 * Utility routine for type conversions, etc. 00347 * 00348 * Pops an operand from the stack and converts 00349 * it to type ty if necessary. 00350 * 00351 * arrexp is treated as it is for cwh_expr_operand 00352 * 00353 *=============================================== 00354 */ 00355 extern WN * 00356 cwh_get_typed_operand(TYPE_ID ty, WN **arrexp) 00357 { 00358 WN *r; 00359 00360 r = cwh_expr_operand(arrexp); 00361 r = cwh_convert_to_ty(r,ty); 00362 return (r); 00363 } 00364 00365 /*=============================================== 00366 * 00367 * cwh_make_typed_opcode 00368 * 00369 * Build an opcode from a type, also checking 00370 * for small types and converting them to 32 bits. 00371 * 00372 *=============================================== 00373 */ 00374 extern OPCODE 00375 cwh_make_typed_opcode(OPERATOR op, TYPE_ID ty1, TYPE_ID ty2) 00376 { 00377 OPCODE opc; 00378 TYPE_ID ti ; 00379 00380 switch (ty1) { 00381 case MTYPE_B: 00382 case MTYPE_I1: 00383 case MTYPE_I2: 00384 ti = MTYPE_I4; 00385 break ; 00386 00387 case MTYPE_U1: 00388 case MTYPE_U2: 00389 ti = MTYPE_U4; 00390 break ; 00391 00392 default: 00393 ti = ty1; 00394 break; 00395 } 00396 opc = OPCODE_make_op(op,ti,ty2); 00397 return (opc); 00398 } 00399 00400 /*=============================================== 00401 * 00402 * cwh_expr_binop 00403 * 00404 * Apply the binop to the two operands at the 00405 * top of the stack and push the result. Conversions 00406 * are added to lhs & rhs if required. 00407 * 00408 *=============================================== 00409 */ 00410 static void 00411 cwh_expr_binop(OPERATOR op,TY_IDX result_ty) 00412 { 00413 00414 WN *rhs ; 00415 WN *lhs ; 00416 WN *wn ; 00417 TYPE_ID bt ; 00418 OPCODE opc ; 00419 TYPE_ID ot; 00420 WN *ae=NULL; 00421 00422 00423 rhs = cwh_expr_operand(&ae); 00424 lhs = cwh_expr_operand(&ae); 00425 00426 //FMZ August 2005 00427 if (WN_operator(rhs)==OPR_STRCTFLD) 00428 rhs = addr_gen_iload_for_strctfld(rhs); 00429 00430 if (WN_operator(lhs)==OPR_STRCTFLD) 00431 lhs = addr_gen_iload_for_strctfld(lhs); 00432 00433 ot = cwh_get_highest_type(rhs,lhs); 00434 if (result_ty) { 00435 bt = TY_mtype(result_ty) ; 00436 } else { 00437 bt = ot; 00438 } 00439 opc = cwh_make_typed_opcode(op, ot, MTYPE_V); 00440 lhs = cwh_convert_to_ty(lhs,ot); 00441 rhs = cwh_convert_to_ty(rhs,ot); 00442 00443 wn = WN_CreateExp2 ( opc, lhs, rhs) ; 00444 00445 /* Need to insert a CVTL on top of the small ops */ 00446 wn = cwh_wrap_cvtl(wn,bt); 00447 00448 wn = cwh_expr_restore_arrayexp(wn,ae); 00449 cwh_stk_push_typed(wn,WN_item,result_ty) ; 00450 } 00451 00452 /*=============================================== 00453 * 00454 * cwh_expr_binop_shift 00455 * 00456 * Apply the binop to the two operands at the 00457 * top of the stack and push the result. The 00458 * shifts yield integer results and can be applied 00459 * to float operands. 00460 * 00461 *=============================================== 00462 */ 00463 static void 00464 cwh_expr_binop_shift(OPERATOR op, TY_IDX result_ty) 00465 { 00466 00467 WN *arg ; 00468 WN *shft ; 00469 WN *wn ; 00470 WN *temp ; 00471 WN *ae=NULL; 00472 00473 TYPE_ID bt ; 00474 TYPE_ID ret_t; 00475 TYPE_ID br ; 00476 TYPE_ID ba ; 00477 OPCODE opc ; 00478 INT bitlen; 00479 INT reslen; 00480 00481 br = TY_mtype(result_ty) ; 00482 ret_t = br; 00483 reslen = MTYPE_size_best(br); 00484 shft = cwh_expr_operand(&ae); 00485 arg = cwh_expr_operand(&ae); 00486 00487 bt = WNRTY(arg); 00488 bitlen = MTYPE_size_best(bt); 00489 00490 if (reslen < 32 && op == OPR_LSHR) { 00491 /* Need to clear out the upper bits */ 00492 arg = WN_Band(bt,arg,WN_Intconst(bt,(1<<reslen)-1)); 00493 } 00494 00495 if (bitlen <= MTYPE_size_best(MTYPE_U4)) 00496 ba = MTYPE_I4 ; 00497 else 00498 ba = MTYPE_I8 ; 00499 00500 if (reslen > 32) { 00501 br = MTYPE_I8; 00502 } else { 00503 br = MTYPE_I4; 00504 } 00505 00506 if (!MTYPE_is_integral(bt)) 00507 arg = WN_Tas(ba,Be_Type_Tbl(bt),arg) ; 00508 00509 opc = cwh_make_typed_opcode(op, br, MTYPE_V); 00510 if (op == OPR_ASHR) { 00511 /* shift is MIN(shift,reslen-1) */ 00512 if (ARCH_mask_shift_counts) { 00513 temp = WN_GT(br,WN_COPY_Tree(shft),WN_Intconst(br,reslen-1)); 00514 temp = cwh_convert_to_ty(temp,br); 00515 temp = WN_Neg(br,temp); 00516 shft = WN_Bior(br,temp,shft); 00517 } 00518 wn = WN_CreateExp2 (opc, arg, shft); 00519 } else { 00520 if (ARCH_mask_shift_counts) { 00521 /* shift is (arg op shift ) & -(shift<reslen) */ 00522 temp = WN_LT(br,WN_COPY_Tree(shft),WN_Intconst(br,reslen)); 00523 temp = cwh_convert_to_ty(temp,br); 00524 temp = WN_Neg(br,temp); 00525 wn = WN_CreateExp2 (opc, arg, shft); 00526 wn = WN_Band(br,wn,temp); 00527 } else { 00528 wn = WN_CreateExp2 (opc, arg, shft); 00529 } 00530 } 00531 00532 wn = cwh_wrap_cvtl(wn,ret_t); 00533 00534 wn = cwh_expr_restore_arrayexp(wn,ae); 00535 cwh_stk_push_typed(wn,WN_item,result_ty); 00536 } 00537 00538 /*=============================================== 00539 * 00540 * cwh_expr_compare 00541 * 00542 * Apply the compare binop to the two operands at the 00543 * top of the stack and push the result. Convert 00544 * both operands 'highest' type before selecting 00545 * operator. 00546 * 00547 * Character operations are diverted to create 00548 * the correct intrinsic. 00549 * 00550 *=============================================== 00551 */ 00552 extern void 00553 cwh_expr_compare(OPERATOR op,TY_IDX ty) 00554 { 00555 00556 WN *rhs ; 00557 WN *lhs ; 00558 WN *wn ; 00559 WN *ae=NULL; 00560 00561 TYPE_ID bt ; 00562 OPCODE opc ; 00563 00564 if (cwh_stk_get_class() == STR_item) 00565 wn = cwh_expr_compare_char(op,ty); 00566 00567 else { 00568 00569 rhs = cwh_expr_operand(&ae); 00570 lhs = cwh_expr_operand(&ae); 00571 00572 bt = cwh_get_highest_type(rhs,lhs); 00573 opc = cwh_make_typed_opcode(op, MTYPE_I4, Mtype_comparison(bt)); 00574 lhs = cwh_convert_to_ty(lhs,bt); 00575 rhs = cwh_convert_to_ty(rhs,bt); 00576 00577 wn = WN_CreateExp2 ( opc, lhs, rhs) ; 00578 00579 WN_set_ty(wn,ty); 00580 00581 wn = cwh_expr_restore_arrayexp(wn,ae); 00582 } 00583 00584 cwh_stk_push_typed(wn,WN_item,ty); 00585 } 00586 00587 /*=================================================== 00588 */ 00589 extern void 00590 fei_leqv(TYPE type) 00591 { 00592 /* generate whirl node with OPR=EQ,but set flag is "logical"*/ 00593 WN *rhs ; 00594 WN *lhs ; 00595 WN *wn ; 00596 WN *ae=NULL; 00597 TY_IDX ty = cast_to_TY(t_TY(type)); 00598 TYPE_ID bt ; 00599 OPCODE opc ; 00600 00601 00602 rhs = cwh_expr_operand(&ae); 00603 lhs = cwh_expr_operand(&ae); 00604 00605 bt = cwh_get_highest_type(rhs,lhs); 00606 opc = cwh_make_typed_opcode(OPR_EQ, MTYPE_I4, Mtype_comparison(bt)); 00607 lhs = cwh_convert_to_ty(lhs,bt); 00608 rhs = cwh_convert_to_ty(rhs,bt); 00609 00610 wn = WN_CreateExp2 ( opc, lhs, rhs) ; 00611 00612 WN_set_ty(wn,ty); 00613 00614 wn = cwh_expr_restore_arrayexp(wn,ae); 00615 00616 /* set eq_logical_flag is LOGICAL */ 00617 00618 WN_Set_Eq_Is_Logical(wn); 00619 00620 cwh_stk_push_typed(wn,WN_item,ty); 00621 00622 00623 } 00624 00625 extern void 00626 fei_lxor(TYPE type) 00627 { 00628 /*generate whirl node with OPR=NEQ,but set flag is "logical" */ 00629 WN *rhs ; 00630 WN *lhs ; 00631 WN *wn ; 00632 WN *ae=NULL; 00633 TY_IDX ty = cast_to_TY(t_TY(type)); 00634 00635 TYPE_ID bt ; 00636 OPCODE opc ; 00637 00638 rhs = cwh_expr_operand(&ae); 00639 lhs = cwh_expr_operand(&ae); 00640 00641 bt = cwh_get_highest_type(rhs,lhs); 00642 opc = cwh_make_typed_opcode(OPR_NE, MTYPE_I4, Mtype_comparison(bt)); 00643 lhs = cwh_convert_to_ty(lhs,bt); 00644 rhs = cwh_convert_to_ty(rhs,bt); 00645 00646 wn = WN_CreateExp2 ( opc, lhs, rhs) ; 00647 00648 WN_set_ty(wn,ty); 00649 00650 wn = cwh_expr_restore_arrayexp(wn,ae); 00651 00652 /* set eq_logical_flag is LOGICAL */ 00653 00654 WN_Set_Eq_Is_Logical(wn); 00655 00656 cwh_stk_push_typed(wn,WN_item,ty); 00657 } 00658 00659 00660 /*=============================================== 00661 * 00662 * cwh_expr_compare_char 00663 * 00664 * Convert the compare binop into an intrinsic OP 00665 * and return the WN of the op. Assumes two 00666 * STR_items are TOS. 00667 * 00668 *=============================================== 00669 */ 00670 static WN * 00671 cwh_expr_compare_char(OPERATOR op, TY_IDX ty) 00672 { 00673 WN * ar[4]; 00674 WN * sz[4]; 00675 BOOL va[4]; 00676 WN * wn ; 00677 INTRINSIC intr; 00678 00679 cwh_stk_pop_STR(); 00680 ar[3] = cwh_expr_operand(NULL); 00681 ar[1] = cwh_expr_address(f_NONE); 00682 00683 sz[3] = NULL; 00684 sz[1] = WN_COPY_Tree(ar[3]); 00685 va[3] = TRUE; 00686 va[1] = FALSE; 00687 00688 cwh_stk_pop_STR(); 00689 ar[2] = cwh_expr_operand(NULL); 00690 ar[0] = cwh_expr_address(f_NONE); 00691 00692 sz[2] = NULL; 00693 sz[0] = WN_COPY_Tree(ar[2]); 00694 va[2] = TRUE; 00695 va[0] = FALSE; 00696 00697 switch(op) { 00698 case OPR_LT: 00699 intr = INTRN_CLTEXPR; 00700 break ; 00701 case OPR_LE: 00702 intr = INTRN_CLEEXPR; 00703 break ; 00704 case OPR_GE: 00705 intr = INTRN_CGEEXPR; 00706 break ; 00707 case OPR_GT: 00708 intr = INTRN_CGTEXPR; 00709 break ; 00710 case OPR_EQ: 00711 intr = INTRN_CEQEXPR; 00712 break ; 00713 case OPR_NE: 00714 intr = INTRN_CNEEXPR; 00715 break ; 00716 00717 default: 00718 DevAssert((0),("Missing char comp")); 00719 00720 } 00721 wn = cwh_intrin_op(intr,4,ar,sz,va,TY_mtype(ty)); 00722 wn = F90_Wrap_ARREXP(wn); 00723 return (wn); 00724 } 00725 00726 /*=============================================== 00727 * 00728 * cwh_expr_compare_logical 00729 * 00730 * Logical WN comparisons don't have a type 00731 * so just pop the items, stick the operator 00732 * on top and push the result. 00733 * 00734 *=============================================== 00735 */ 00736 static void 00737 cwh_expr_compare_logical(OPCODE opc,TY_IDX ty) 00738 { 00739 WN * rhs; 00740 WN * lhs; 00741 WN * wn ; 00742 WN *ae=NULL; 00743 00744 rhs = cwh_expr_operand(&ae); 00745 lhs = cwh_expr_operand(&ae); 00746 wn = WN_CreateExp2 ( opc, lhs, rhs) ; 00747 00748 WN_set_ty(wn,ty); 00749 wn = cwh_expr_restore_arrayexp(wn,ae); 00750 00751 cwh_stk_push_typed(wn,WN_item,ty); 00752 } 00753 00754 /*=============================================== 00755 * 00756 * cwh_expr_compare_bitwise 00757 * 00758 * Bitwise WN comparisons for all types. Convert 00759 * bits to integer type (if they aren't already) 00760 * using TAS operate & push the result. 00761 * The result type should be either I8 or I4. 00762 * 00763 *=============================================== 00764 */ 00765 static void 00766 cwh_expr_compare_bitwise(OPERATOR op,TY_IDX ty) 00767 { 00768 WN * rhs; 00769 WN * lhs; 00770 WN * wn ; 00771 TY_IDX ta ; 00772 00773 TYPE_ID bt; 00774 TYPE_ID br; 00775 TYPE_ID ba; 00776 TYPE_ID rhs_t,lhs_t; 00777 OPCODE opc; 00778 WN *ae=NULL; 00779 00780 bt = br = TY_mtype(ty); 00781 if (bt == MTYPE_U4) br = MTYPE_I4 ; 00782 if (bt == MTYPE_U8) br = MTYPE_I8 ; 00783 00784 rhs = cwh_expr_operand(&ae) ; 00785 lhs = cwh_expr_operand(&ae) ; 00786 rhs_t = WN_rtype(rhs); 00787 lhs_t = WN_rtype(lhs); 00788 00789 ta = cwh_types_scalar_TY(cwh_types_WN_TY(rhs,FALSE)); 00790 ba = TY_mtype(ta); 00791 00792 if (!MTYPE_is_integral(rhs_t)) { 00793 rhs = WN_Tas(br,ta,rhs) ; 00794 } 00795 if (!MTYPE_is_integral(lhs_t)) { 00796 lhs = WN_Tas(br,ta,lhs) ; 00797 } 00798 opc = cwh_make_typed_opcode(op,br,MTYPE_V); 00799 wn = WN_CreateExp2 ( opc, lhs, rhs) ; 00800 00801 WN_set_ty(wn,ty); 00802 00803 wn = cwh_expr_restore_arrayexp(wn,ae); 00804 cwh_stk_push(wn,WN_item); 00805 } 00806 00807 /*=============================================== 00808 * 00809 * fei_lneg 00810 * 00811 * .not. processing - similar to cwh_expr_unop, 00812 * except result doesn't have a type. 00813 * 00814 *=============================================== 00815 */ 00816 extern void 00817 fei_lneg(TYPE result) 00818 { 00819 WN * lhs; 00820 WN * wn ; 00821 WN *ae=NULL; 00822 TY_IDX ts; 00823 00824 ts = cast_to_TY(t_TY(result)); 00825 00826 lhs = cwh_expr_operand(&ae); 00827 wn = WN_CreateExp1(OPC_I4LNOT, lhs) ; 00828 00829 WN_set_ty(wn,ts); 00830 00831 wn = cwh_expr_restore_arrayexp(wn,ae); 00832 cwh_stk_push_typed(wn,WN_item,cast_to_TY(t_TY(result))); 00833 } 00834 00835 /*=============================================== 00836 * 00837 * cwh_expr_unop 00838 * 00839 * Apply the unop to the operand at the 00840 * top of the stack and push the result. 00841 * The operand is converted to the type 00842 * of the result. 00843 * 00844 *=============================================== 00845 */ 00846 static void 00847 cwh_expr_unop(OPERATOR op,TY_IDX result_ty) 00848 { 00849 00850 WN *lhs ; 00851 WN *wn ; 00852 WN *ae=NULL; 00853 00854 TYPE_ID bt ; 00855 OPCODE opc ; 00856 00857 bt = TY_mtype(result_ty) ; 00858 opc = cwh_make_typed_opcode(op, bt, MTYPE_V); 00859 lhs = cwh_get_typed_operand(bt,&ae); 00860 00861 wn = WN_CreateExp1 ( opc, lhs) ; 00862 WN_set_ty(wn,result_ty); 00863 00864 wn = cwh_wrap_cvtl(wn,bt); 00865 00866 wn = cwh_expr_restore_arrayexp(wn,ae); 00867 cwh_stk_push(wn,WN_item); 00868 } 00869 00870 /*=================================================== 00871 * 00872 * cwh_expr_bincalc 00873 * 00874 * Given a binary op, and two WNs create the WN of 00875 * the result. Used by address calculations, only. 00876 * The type of the result is the type of the first 00877 * argument. 00878 * 00879 ==================================================== 00880 */ 00881 extern WN * 00882 cwh_expr_bincalc(OPERATOR op, WN * wn1, WN * wn2) 00883 { 00884 TYPE_ID bt ; 00885 00886 bt = cwh_get_highest_type(wn1,wn2); 00887 wn1 = cwh_convert_to_ty(wn1,bt); 00888 wn2 = cwh_convert_to_ty(wn2,bt); 00889 00890 return WN_CreateExp2 (OPCODE_make_op(op,bt,MTYPE_V), 00891 wn1, 00892 wn2) ; 00893 00894 } 00895 00896 /*=============================================== 00897 * 00898 * cwh_expr_operand 00899 * 00900 * Pop the top of the stack and make it 00901 * into an operand. If it's a WN, then it may be a 00902 * constant or expression, and it's just returned, 00903 * unless an OPC_ARRAY or OPC_ARRSECTION when 00904 * a load is added. An ST requires a load. A FLD 00905 * loads from its offset. 00906 * 00907 * if arrexp is non-null, and the returned node is an 00908 * ARRAYEXP node, *arrexp is set to the ARRAYEXP node, and 00909 * the first child if the ARRAYEXP is returned. 00910 *=============================================== 00911 */ 00912 extern WN * 00913 cwh_expr_operand(WN **arrexp) 00914 { 00915 WN * wn ; 00916 ST * st ; 00917 TY_IDX ts ; 00918 00919 FLD_det det; 00920 00921 ts = cwh_stk_get_TY(); 00922 00923 switch(cwh_stk_get_class()) { 00924 case WN_item: 00925 case WN_item_whole_array: 00926 wn = cwh_stk_pop_WN(); 00927 if (wn == NULL) 00928 return(wn); 00929 00930 00931 if (cwh_addr_is_array(wn)) { 00932 wn = cwh_addr_load_WN(wn,0,ts); 00933 } else if (cwh_addr_is_section(wn)) { 00934 wn = cwh_addr_load_WN(wn,0,ts); 00935 if (Full_arrayexp) { 00936 wn = F90_Wrap_ARREXP(wn); 00937 } 00938 } 00939 00940 00941 wn = cwh_expr_extract_arrayexp(wn,arrexp); 00942 break ; 00943 00944 case ADDR_item: 00945 wn = cwh_stk_pop_ADDR(); 00946 break ; 00947 00948 case DEREF_item: 00949 wn = cwh_stk_pop_DEREF(); 00950 wn = cwh_addr_load_WN(wn,0,0); 00951 break ; 00952 00953 case ST_item: 00954 case ST_item_whole_array: 00955 st = cwh_stk_pop_ST(); 00956 wn = cwh_addr_load_ST(st,0,0); 00957 break ; 00958 00959 case FLD_item: 00960 det = cwh_addr_offset(); 00961 00962 if (cwh_stk_get_class() == ST_item || cwh_stk_get_class() == ST_item_whole_array) { 00963 st = cwh_stk_pop_ST(); 00964 wn = cwh_addr_load_ST(st,det.off,det.type); 00965 00966 } else { 00967 00968 wn = cwh_stk_pop_WHIRL(); 00969 wn = cwh_expr_extract_arrayexp(wn,DELETE_ARRAYEXP_WN); 00970 wn = cwh_addr_load_WN(wn,det.off,det.type); 00971 if (Full_arrayexp) { 00972 wn = F90_Wrap_ARREXP(wn); 00973 } 00974 wn = cwh_expr_extract_arrayexp(wn,arrexp); 00975 } 00976 break ; 00977 00978 case PCONST_item: 00979 st = (ST *) cwh_stk_pop_PCONST(); 00980 wn = cwh_addr_address_ST(st); 00981 break; 00982 00983 default: 00984 DevAssert((0),("Bad operand")); 00985 } 00986 return (wn); 00987 } 00988 00989 /*=============================================== 00990 * 00991 * cwh_expr_address 00992 * 00993 * Makes an address of the top of the stack and 00994 * returns it. A STR_item has its length thrown 00995 * away. A WN constant gets an LDA, otherwise its 00996 * assumed an WN is an address. An INTCONST is 00997 * entered into the symbol table & an expression 00998 * may be saved. An address on the stack may be NULL 00999 * if the dope vector routines have already processed it. 01000 * FLD items are similar to WN_items, but get an 01001 * ADD of the offset to the component. The TY of 01002 * the FLD is thrown away. 01003 * 01004 * Sets ST_addr bits depending of setting of flag 01005 * 01006 *=============================================== 01007 */ 01008 extern WN * 01009 cwh_expr_address(FLAG flag) 01010 { 01011 WN * wn ; 01012 ST * st ; 01013 01014 FLD_det det ; 01015 01016 switch(cwh_stk_get_class()) { 01017 case WN_item: 01018 case WN_item_whole_array: 01019 case ADDR_item: 01020 case DEREF_item: 01021 wn = cwh_stk_pop_WHIRL(); 01022 01023 if (wn) { 01024 if (flag) { 01025 st = cwh_addr_WN_ST(wn); 01026 cwh_expr_set_flags(st, flag); 01027 } 01028 } 01029 break; 01030 01031 case ST_item: 01032 case ST_item_whole_array: 01033 st = cwh_stk_pop_ST(); 01034 wn = cwh_addr_address_ST(st); 01035 if (flag) 01036 cwh_expr_set_flags(st, flag); 01037 break; 01038 01039 case STR_item: 01040 cwh_stk_pop_STR(); 01041 WN_Delete(cwh_expr_operand(NULL)); /* Get rid of the length */ 01042 wn = cwh_expr_address(flag); 01043 break; 01044 01045 case FLD_item: 01046 det = cwh_addr_offset(); 01047 01048 if (cwh_stk_get_class() == ST_item || 01049 cwh_stk_get_class() == ST_item_whole_array) { 01050 01051 st = cwh_stk_pop_ST(); 01052 wn = cwh_addr_address_ST(st,det.off,det.type); 01053 if (flag) 01054 cwh_expr_set_flags(st, flag); 01055 01056 } else { 01057 wn = cwh_expr_address(flag); 01058 wn = cwh_expr_bincalc(OPR_ADD,wn,WN_Intconst(Pointer_Mtype,det.off)); 01059 } 01060 break ; 01061 01062 default: 01063 DevAssert((0),("Odd address")); 01064 } 01065 01066 return (wn); 01067 } 01068 01069 /*=============================================== 01070 * 01071 * fei_<binop> 01072 * 01073 * Use common binary op routine - one of 01074 * cwh_expr_binop,cwh_expr_compare, 01075 * cwh_expr_binop_shift 01076 * cwh_expr_compare_logical 01077 * cwh_expr_compare_bitwise 01078 01079 *=============================================== 01080 */ 01081 01082 #define binop_routine(name,opr) \ 01083 extern void name (TYPE type) \ 01084 { \ 01085 cwh_expr_binop(opr,cast_to_TY(t_TY(type))); \ 01086 } 01087 01088 #define binop_shift_routine(name,opr) \ 01089 extern void name (TYPE type) \ 01090 { \ 01091 cwh_expr_binop_shift(opr,cast_to_TY(t_TY(type))); \ 01092 } 01093 01094 #define compare_routine(name,opr) \ 01095 extern void name (TYPE type) \ 01096 { \ 01097 cwh_expr_compare(opr,cast_to_TY(t_TY(type))); \ 01098 } 01099 01100 #define compare_logical(name,opr_l,opr_c) \ 01101 extern void name (TYPE type) \ 01102 { \ 01103 cwh_expr_compare_logical(FTN_Short_Circuit_On ? opr_c : opr_l,cast_to_TY(t_TY(type))); \ 01104 } 01105 01106 #define compare_bitwise(name,opr) \ 01107 extern void name (TYPE type) \ 01108 { \ 01109 cwh_expr_compare_bitwise(opr,cast_to_TY(t_TY(type))); \ 01110 } 01111 binop_routine(fei_plus,OPR_ADD) 01112 binop_routine(fei_minus,OPR_SUB) 01113 binop_routine(fei_mult,OPR_MPY) 01114 binop_routine(fei_div,OPR_DIV) 01115 compare_routine(fei_gt,OPR_GT) 01116 compare_routine(fei_ge,OPR_GE) 01117 compare_routine(fei_lt,OPR_LT) 01118 compare_routine(fei_le,OPR_LE) 01119 compare_routine(fei_eq,OPR_EQ) 01120 compare_routine(fei_ne,OPR_NE) 01121 compare_bitwise(fei_and,OPR_BAND) 01122 compare_bitwise(fei_xor,OPR_BXOR) 01123 compare_logical(fei_land ,OPC_I4LAND, OPC_I4CAND) 01124 // compare_routine(fei_leqv ,OPR_EQ) 01125 compare_logical(fei_lor ,OPC_I4LIOR, OPC_I4CIOR) 01126 binop_shift_routine(fei_lshift ,OPR_SHL) 01127 binop_shift_routine(fei_rshift ,OPR_LSHR) 01128 binop_shift_routine(fei_ashift ,OPR_ASHR) 01129 // compare_routine(fei_lxor ,OPR_NE) 01130 compare_bitwise(fei_or ,OPR_BIOR) 01131 01132 01133 /* Bitwise equivalence */ 01134 extern void 01135 fei_eqv(TYPE type) 01136 { 01137 fei_xor(type); 01138 fei_bneg(type); 01139 } 01140 01141 /*=============================================== 01142 * 01143 * fei_islg 01144 * 01145 * != comparison, implemented as is less than or 01146 * greater than comparison. 01147 * 01148 *=============================================== 01149 */ 01150 extern void 01151 fei_islg(TYPE type) 01152 { 01153 WN *arg1, *arg2, *r1, *r2; 01154 01155 arg1 = cwh_expr_operand(NULL); 01156 arg2 = cwh_expr_operand(NULL); 01157 cwh_stk_push(WN_COPY_Tree(arg2),WN_item); 01158 cwh_stk_push(WN_COPY_Tree(arg1),WN_item); 01159 cwh_expr_compare(OPR_LT,0); 01160 01161 r1 = cwh_expr_operand(NULL); 01162 cwh_stk_push(arg2,WN_item); 01163 cwh_stk_push(arg1,WN_item); 01164 cwh_expr_compare(OPR_GT,0); 01165 01166 r2 = cwh_expr_operand(NULL); 01167 cwh_stk_push(r1,WN_item); 01168 cwh_stk_push(r2,WN_item); 01169 fei_lor(type); 01170 } 01171 01172 extern void 01173 fei_multiply_high(TYPE type) 01174 { 01175 /* Can't use cwh_expr_binop, since we need UNSIGNED multiply */ 01176 WN *rhs ; 01177 WN *lhs ; 01178 WN *wn ; 01179 OPCODE opc ; 01180 TYPE_ID ot; 01181 WN *ae=NULL; 01182 01183 rhs = cwh_expr_operand(&ae); 01184 lhs = cwh_expr_operand(&ae); 01185 01186 ot = cwh_get_highest_type(rhs,lhs); 01187 if (ot == MTYPE_I8) { 01188 opc = OPC_U8HIGHMPY; 01189 ot = MTYPE_U8; 01190 } else { 01191 opc = OPC_U4HIGHMPY; 01192 ot = MTYPE_U4; 01193 } 01194 01195 lhs = cwh_convert_to_ty(lhs,ot); 01196 rhs = cwh_convert_to_ty(rhs,ot); 01197 01198 wn = WN_CreateExp2 ( opc, lhs, rhs) ; 01199 01200 wn = cwh_expr_restore_arrayexp(wn,ae); 01201 cwh_stk_push(wn,WN_item); 01202 } 01203 01204 /*=============================================== 01205 * 01206 * fei_<unop> 01207 * 01208 * Use common unary op routine 01209 * 01210 *=============================================== 01211 */ 01212 #define unop_routine(name,opr) \ 01213 extern void name (TYPE type) \ 01214 { \ 01215 cwh_expr_unop(opr,cast_to_TY(t_TY(type))); \ 01216 } 01217 01218 /*=============================================== 01219 * 01220 * fei_imag 01221 * 01222 * Get the imaginary part 01223 * 01224 *=============================================== 01225 */ 01226 extern void 01227 fei_imag(TYPE type) 01228 { 01229 WN *rhs, *wn; 01230 TY_IDX ty; 01231 TYPE_ID t,rt; 01232 WN *ae=NULL; 01233 01234 ty = cast_to_TY(t_TY(type)); 01235 t = TY_mtype(ty) ; 01236 rhs = cwh_expr_operand(&ae); 01237 rt = Mtype_complex_to_real(WN_rtype(rhs)); 01238 wn = WN_CreateExp1(cwh_make_typed_opcode(OPR_IMAGPART,rt,MTYPE_V),rhs); 01239 01240 wn = cwh_convert_to_ty(wn,t); 01241 wn = cwh_expr_restore_arrayexp(wn,ae); 01242 cwh_stk_push(wn,WN_item); 01243 } 01244 01245 /*=============================================== 01246 * 01247 * fei_bneg 01248 * 01249 * Bitwise NOT on top of stack 01250 * 01251 *=============================================== 01252 */ 01253 extern void 01254 fei_bneg(TYPE type) 01255 { 01256 01257 WN *lhs ; 01258 WN *wn ; 01259 WN *ae=NULL; 01260 01261 TYPE_ID bt, lhs_t ; 01262 OPCODE opc ; 01263 TY_IDX ta, result_ty; 01264 01265 result_ty = cast_to_TY(t_TY(type)); 01266 bt = TY_mtype(result_ty) ; 01267 01268 if (MTYPE_is_unsigned(bt)) { 01269 bt = MTYPE_complement(bt); 01270 } 01271 01272 lhs = cwh_expr_operand(&ae) ; 01273 lhs_t = WN_rtype(lhs); 01274 01275 ta = cwh_types_scalar_TY(cwh_types_WN_TY(lhs,FALSE)); 01276 if (!MTYPE_is_integral(lhs_t)) { 01277 lhs = WN_Tas(bt,ta,lhs) ; 01278 } 01279 01280 opc = cwh_make_typed_opcode(OPR_BNOT, bt, MTYPE_V); 01281 01282 wn = WN_CreateExp1 ( opc, lhs) ; 01283 01284 wn = cwh_wrap_cvtl(wn,bt); 01285 01286 wn = cwh_expr_restore_arrayexp(wn,ae); 01287 cwh_stk_push_typed(wn,WN_item,Be_Type_Tbl(bt)); 01288 } 01289 01290 unop_routine(fei_uminus,OPR_NEG) 01291 01292 /*=============================================== 01293 * 01294 * fei_paren 01295 * 01296 * If type is integer/logical ignore, as WHIRL 01297 * doesn't have an suitable operator code. Otherwise 01298 * use the unary operator routine. 01299 * 01300 *=============================================== 01301 */ 01302 extern void 01303 fei_paren(TYPE type,INT processing_call) 01304 { 01305 01306 TY_IDX ty ; 01307 TYPE_ID t; 01308 WN* wni; 01309 TY_IDX tyi ; 01310 01311 ty = cast_to_TY(t_TY(type)); 01312 ty = cwh_types_scalar_TY(ty); 01313 t = TY_mtype(ty); 01314 01315 if (processing_call) 01316 { 01317 if (cwh_stk_get_class()==WN_item){ 01318 wni = cwh_stk_pop_WN(); 01319 if (WN_operator(wni)==OPR_STRCTFLD) 01320 wni = addr_gen_iload_for_strctfld(wni); 01321 tyi = WN_ty(wni); 01322 cwh_stk_push_typed(wni,WN_item,tyi); 01323 } 01324 } 01325 01326 if (MTYPE_is_float(t) || MTYPE_is_complex(t) || 01327 processing_call) { 01328 cwh_expr_unop(OPR_PAREN,ty); 01329 } 01330 } 01331 01332 /*=============================================== 01333 * 01334 * fei_max/min 01335 * 01336 * create max/min via common binop routine. 01337 * 01338 *=============================================== 01339 */ 01340 extern void 01341 fei_max(INT count, TYPE type) 01342 { 01343 INT i; 01344 for (i = 1; i < count; i++) { 01345 cwh_expr_binop(OPR_MAX,cast_to_TY(t_TY(type))); 01346 } 01347 01348 } 01349 extern void 01350 fei_min(INT count, TYPE type) 01351 { 01352 INT i; 01353 for (i = 1; i < count; i++) { 01354 cwh_expr_binop(OPR_MIN,cast_to_TY(t_TY(type))); 01355 } 01356 } 01357 01358 /*=============================================== 01359 * 01360 * fei_select 01361 * 01362 * Implement the MERGE intrinsic. The mask is 01363 * TOS, then T items, F items and the destination. 01364 * 01365 * Generally a select is issued, and pushed onto 01366 * the stack so the result can be used, eg: by 01367 * fei_store. If it's an aggregate - a character 01368 * or derived type, then the MERGE intrinsic op 01369 * is used. 01370 * 01371 * This also implements the CVM... intrinsics 01372 * 01373 *=============================================== 01374 */ 01375 extern void 01376 fei_select(TYPE type) 01377 { 01378 WN *t_case,*f_case,*condition; 01379 WN * wn; 01380 TY_IDX ty; 01381 WN *strlen; 01382 WN *addr; 01383 TYPE_ID bt; 01384 TYPE_ID rt; 01385 WN *args[3]; 01386 WN *ae=NULL; 01387 01388 ty = cast_to_TY(t_TY(type)); 01389 01390 condition = cwh_expr_operand(&ae); 01391 01392 if (TY_is_character(ty)) { 01393 cwh_stk_pop_STR(); 01394 strlen = cwh_expr_operand(NULL); 01395 addr = cwh_expr_address(f_NONE); 01396 f_case = cwh_addr_mload(addr,0,ty,strlen); 01397 01398 cwh_stk_pop_STR(); 01399 strlen = cwh_expr_operand(NULL); 01400 addr = cwh_expr_address(f_NONE); 01401 t_case = cwh_addr_mload(addr,0,ty,strlen); 01402 01403 } else { 01404 f_case = cwh_expr_operand(&ae); 01405 t_case = cwh_expr_operand(&ae); 01406 } 01407 01408 bt = WN_rtype(t_case); 01409 01410 if (bt == MTYPE_M) { 01411 01412 /* character,derived type - build an intrinsic_op */ 01413 01414 args[0] = cwh_intrin_wrap_value_parm(condition); 01415 args[1] = cwh_intrin_wrap_value_parm(t_case); 01416 args[2] = cwh_intrin_wrap_value_parm(f_case); 01417 if (TY_is_character(ty)) { 01418 wn = WN_Create_Intrinsic(OPC_U4INTRINSIC_OP,INTRN_MERGE,3,args); 01419 cwh_stk_push_STR(WN_COPY_Tree(strlen),wn,ty,WN_item); 01420 } else { 01421 wn = WN_Create_Intrinsic(OPC_MINTRINSIC_OP,INTRN_MERGE,3,args); 01422 wn = cwh_expr_restore_arrayexp(wn,ae); 01423 cwh_stk_push(wn,WN_item); 01424 } 01425 } else { 01426 /* 01427 * In order to handle the CVMGT intrinsic and its ilk, we check the base types 01428 * of the TRUE and FALSE cases and wrap them with TAS as necessary. 01429 */ 01430 rt = TY_mtype(ty); 01431 if (MTYPE_is_integral(rt)) { 01432 if (!MTYPE_is_integral(WNRTY(t_case))) { 01433 t_case = WN_Tas(rt,Be_Type_Tbl(WNRTY(t_case)),t_case) ; 01434 } 01435 if (!MTYPE_is_integral(WNRTY(f_case))) { 01436 f_case = WN_Tas(rt,Be_Type_Tbl(WNRTY(f_case)),f_case) ; 01437 } 01438 } 01439 01440 wn = WN_CreateExp3(cwh_make_typed_opcode(OPR_SELECT,rt,MTYPE_V),condition,t_case,f_case); 01441 wn = cwh_wrap_cvtl(wn,rt); 01442 wn = cwh_expr_restore_arrayexp(wn,ae); 01443 cwh_stk_push_typed(wn,WN_item,Be_Type_Tbl(rt)); 01444 } 01445 } 01446 01447 01448 /*============================================= 01449 * 01450 * fei_cvtop 01451 * 01452 * Convert TOS to the given type. 01453 * 01454 *============================================= 01455 */ 01456 extern void 01457 fei_cvtop(TYPE type) 01458 { 01459 WN *wn ; 01460 TYPE_ID bt ; 01461 TYPE_ID ot ; 01462 WN *addr; 01463 TY_IDX ty; 01464 WN *ival; 01465 WN *icall; 01466 WN *ae=NULL; 01467 01468 ty = cast_to_TY(t_TY(type)); 01469 01470 /* Check for converts to TYPELESS, for which we just use a TAS */ 01471 01472 if (type.basic_type == T_ypeless) { 01473 wn = cwh_expr_operand(&ae); 01474 ot = WNRTY(wn) ; 01475 01476 if (!MTYPE_is_integral(ot)) { 01477 wn = WN_Tas(TY_mtype(ty),Be_Type_Tbl(ot),wn) ; 01478 } 01479 01480 wn = cwh_expr_restore_arrayexp(wn,ae); 01481 cwh_stk_push_typed(wn,WN_item,ty); 01482 01483 } else if (TY_is_character(ty)) { 01484 01485 ival = cwh_intrin_wrap_value_parm(cwh_expr_operand(&ae)); 01486 icall = WN_Create_Intrinsic(OPC_U4INTRINSIC_OP,INTRN_CHAR,1,&ival); 01487 icall = cwh_expr_restore_arrayexp(icall,ae); 01488 cwh_stk_push_STR(WN_Intconst(MTYPE_I4,1),icall,ty,WN_item); 01489 01490 } else { 01491 01492 bt = TY_mtype(ty); 01493 01494 if (cwh_stk_get_class() == STR_item) { 01495 cwh_stk_pop_STR(); 01496 WN_Delete(cwh_expr_operand(NULL)); /* Get rid of the length */ 01497 addr = cwh_expr_address(f_NONE); 01498 01499 if (WN_opcode(addr) == OPC_U4INTRINSIC_OP && 01500 WN_intrinsic(addr) == INTRN_CHAR) { 01501 01502 addr = cwh_expr_dispose_of_char(addr); 01503 01504 /* ichar(char(x)) ==> x & 255 */ 01505 wn = WN_Band(MTYPE_I4,addr,WN_Intconst(MTYPE_I4,255)); 01506 wn = F90_Wrap_ARREXP(wn); 01507 } else { 01508 01509 wn = cwh_addr_load_WN(addr,0,Be_Type_Tbl(MTYPE_U1)); 01510 wn = WN_Band(MTYPE_I4,wn,WN_Intconst(MTYPE_I4,255)); 01511 /* Convert to bt */ 01512 wn = cwh_convert_to_ty(wn,bt); 01513 } 01514 } else { 01515 wn = cwh_get_typed_operand(bt,&ae); 01516 } 01517 01518 if (WNOPR(wn) == OPR_INTCONST) { 01519 wn = cwh_expr_restore_arrayexp(wn,ae); 01520 cwh_stk_push_typed(wn,WN_item,ty); 01521 } else { 01522 wn = cwh_expr_restore_arrayexp(wn,ae); 01523 cwh_stk_push_typed(wn,WN_item,ty); 01524 } 01525 01526 } /* Non-character */ 01527 01528 } 01529 01530 /*============================================= 01531 * 01532 * fei_len 01533 * 01534 * Used to establish the length of a DUMMY argument 01535 * or to implement the LEN function applied 01536 * to a character expression. 01537 * 01538 * TOS is an ST if the length of a DUMMY or 01539 * a STR_item if it's a character expression. 01540 * In both cases we push the length. For a 01541 * dummy we have to look up the value in the 01542 * list of arguments associated with the 01543 * current entry point (dummy args are 01544 * processed in the preamble). 01545 * 01546 * An ST may also occur for a CHARACTER pointer. 01547 * 01548 *============================================= 01549 */ 01550 extern void 01551 fei_len(TYPE type) 01552 { 01553 ST * st ; 01554 ST * ln ; 01555 WN * wn ; 01556 01557 01558 switch(cwh_stk_get_class()) { 01559 case ST_item: 01560 case ST_item_whole_array: 01561 st = cwh_stk_pop_ST(); 01562 ln = cwh_auxst_find_dummy_len(st); 01563 if (ln == NULL) { 01564 if (ST_sclass(st) == SCLASS_FORMAL) 01565 Fatal_Error ("Unsupported LEN on character dummy : %s",ST_name(st)); 01566 else 01567 Fatal_Error ("No LEN type parameter: %s", ST_name(st)); 01568 01569 } 01570 cwh_stk_push(ln,ST_item); 01571 break; 01572 01573 case STR_item: 01574 cwh_stk_pop_STR(); 01575 wn = cwh_expr_operand(NULL); 01576 cwh_stk_pop_whatever(); 01577 cwh_stk_push(wn,WN_item); 01578 break; 01579 01580 default: 01581 DevAssert((0),("Odd LEN")); 01582 01583 } 01584 } 01585 01586 01587 /*============================================= 01588 * 01589 * fei_null_expr 01590 * 01591 * push a null WN onto the stack. 01592 * 01593 *============================================= 01594 */ 01595 extern void 01596 fei_null_expr (void) 01597 01598 { 01599 WN *null_wn = NULL; 01600 cwh_stk_push(null_wn,WN_item); 01601 01602 } 01603 01604 /*============================================= 01605 * 01606 * fei_implicit_expr 01607 * 01608 * push a OPR_IMPLICIT_BND WN onto the stack. 01609 * 01610 *============================================= 01611 */ 01612 extern void 01613 fei_implicit_expr (void) 01614 01615 { 01616 OPCODE opc; 01617 // WN *null_wn = NULL; 01618 WN * wn ; 01619 opc = OPCODE_make_op(OPR_IMPLICIT_BND,MTYPE_V,MTYPE_V); 01620 wn = WN_Create(opc,0); 01621 01622 // March cwh_stk_push(null_wn,WN_item); 01623 cwh_stk_push(wn,WN_item); 01624 } 01625 01626 01627 /* 01628 * Generate a mask of len bits of type TY 01629 * valid for 0<= len <= 64 01630 */ 01631 extern 01632 WN * cwh_generate_bitmask(WN *len, TYPE_ID ty) 01633 { 01634 WN *mask; 01635 if (MTYPE_size_reg(ty) != 64 || !ARCH_mask_shift_counts) { 01636 /* Optimization: we use 64 bit shift */ 01637 mask = WN_Intconst(MTYPE_I8,1); 01638 } else { 01639 /* Need to be a little more clever */ 01640 mask = WN_NE(ty,WN_Intconst(MTYPE_I8,64),WN_COPY_Tree(len)); 01641 mask = cwh_convert_to_ty(mask,MTYPE_I8); 01642 } 01643 01644 mask = WN_Shl(MTYPE_I8,mask,len); 01645 mask = cwh_expr_bincalc(OPR_SUB,mask,WN_Intconst(MTYPE_I8,1)); 01646 mask = cwh_convert_to_ty(mask,ty); 01647 return (mask); 01648 } 01649 01650 /*============================================= 01651 * 01652 * fei_mask 01653 * 01654 * push a bitmask on the stack. 01655 * MASK(I) is 01656 * set leftmost I bits if I < bitlen. This is -1 << (bitlen - I) 01657 * set rightmost 2*bitlen-I bits if I >= bitlen 01658 * 01659 *============================================= 01660 */ 01661 extern void 01662 fei_mask (TYPE type) 01663 { 01664 WN *wn,*arg,*t1,*t2; 01665 TYPE_ID t; 01666 WN *ae=NULL; 01667 01668 t = TY_mtype(cast_to_TY(t_TY(type))); 01669 01670 arg = cwh_expr_operand(&ae); 01671 01672 switch (t) { 01673 01674 case MTYPE_U1: 01675 case MTYPE_I1: 01676 /* we can use a neat little trick for this */ 01677 wn = WN_CreateExp2(OPC_I4LSHR,WN_Intconst(MTYPE_I4,0xff00LL),arg); 01678 wn = cwh_convert_to_ty(wn,MTYPE_I1); 01679 break; 01680 01681 case MTYPE_U2: 01682 case MTYPE_I2: 01683 /* we can use a neat little trick for this */ 01684 wn = WN_CreateExp2(OPC_I4LSHR,WN_Intconst(MTYPE_U4,0xffff0000LL),arg); 01685 wn = cwh_convert_to_ty(wn,MTYPE_I2); 01686 break; 01687 01688 case MTYPE_U4: 01689 case MTYPE_I4: 01690 /* we can use a neat little trick for this */ 01691 wn = WN_CreateExp2(OPC_I8LSHR,WN_Intconst(MTYPE_I8,0xffffffff00000000LL),arg); 01692 wn = cwh_convert_to_ty(wn,MTYPE_I4); 01693 break; 01694 case MTYPE_U8: 01695 case MTYPE_I8: 01696 /* Uglier code: 01697 * ~(-1 >> arg) if arg < 64 01698 * bitmask (128 - arg) if arg >= 64 01699 */ 01700 t1 = cwh_expr_bincalc(OPR_LSHR,WN_Intconst(MTYPE_I8,-1),WN_COPY_Tree(arg)); 01701 t1 = WN_CreateExp1(OPC_I8BNOT,t1); 01702 t2 = cwh_expr_bincalc(OPR_SUB,WN_Intconst(MTYPE_I8,128),WN_COPY_Tree(arg)); 01703 t2 = cwh_generate_bitmask(t2,MTYPE_I8); 01704 wn = WN_CreateExp2(OPC_I4I8LT,arg,WN_Intconst(t,64)); 01705 wn = WN_CreateExp3(OPC_I8SELECT,wn,t1,t2); 01706 } 01707 01708 wn = cwh_expr_restore_arrayexp(wn,ae); 01709 cwh_stk_push_typed(wn,WN_item,Be_Type_Tbl(t)); 01710 } 01711 01712 01713 /*============================================= 01714 * 01715 * fei_mbits 01716 * 01717 * CSMG(x1, x2, x3) 01718 * 01719 * Bit by bit selective merge. (x1 AND x3) OR (x2 AND NOT x3) 01720 * 01721 * x1, x2, x3 are all the same length objects (the FE assures this) 01722 * 01723 * 01724 *============================================= 01725 */ 01726 extern void 01727 fei_mbits (TYPE type) 01728 { 01729 WN *wn,*a1,*a2,*mask; 01730 WN *ae=NULL; 01731 01732 mask = cwh_expr_operand(&ae); 01733 a2 = cwh_expr_operand(&ae); 01734 a1 = cwh_expr_operand(&ae); 01735 01736 cwh_stk_push(a1,WN_item); 01737 cwh_stk_push(WN_COPY_Tree(mask),WN_item); 01738 fei_and(type); /* Stack contains a1 & mask */ 01739 01740 01741 cwh_stk_push(mask,WN_item); 01742 fei_bneg(type); /* Stack contains NOT mask */ 01743 01744 01745 cwh_stk_push(a2,WN_item); 01746 fei_and(type); 01747 fei_or(type); 01748 01749 wn = cwh_expr_operand(NULL); 01750 wn = cwh_expr_restore_arrayexp(wn,ae); 01751 cwh_stk_push(wn,WN_item); 01752 } 01753 01754 01755 01756 /*============================================= 01757 * 01758 * fei_new_binop_cshift 01759 * 01760 * Implement a circular left-shift. May be applied 01761 * to types other than integers, so convert operand 01762 * via TAS if required. 01763 * 01764 *============================================= 01765 */ 01766 extern void 01767 fei_new_binop_cshift (TYPE type) 01768 { 01769 WN *wn,*shift,*arg; 01770 WN *t1; 01771 WN *ae=NULL; 01772 INT64 bitlen; 01773 TYPE_ID bt ; 01774 TYPE_ID br ; 01775 01776 shift = cwh_expr_operand(&ae); 01777 arg = cwh_expr_operand(&ae); 01778 01779 bt = WNRTY(arg); 01780 bitlen = MTYPE_size_best(bt); 01781 01782 if (bitlen <= MTYPE_size_best(MTYPE_U4)) 01783 br = MTYPE_I4 ; 01784 else 01785 br = MTYPE_I8 ; 01786 01787 if (!MTYPE_is_integral(bt)) 01788 arg = WN_Tas(br,Be_Type_Tbl(bt),arg) ; 01789 01790 t1 = cwh_expr_bincalc(OPR_SUB,WN_Intconst(MTYPE_I4,bitlen),WN_COPY_Tree(shift)); 01791 t1 = cwh_expr_bincalc(OPR_LSHR,WN_COPY_Tree(arg),t1); 01792 01793 wn = cwh_expr_bincalc(OPR_SHL,arg,shift); 01794 wn = cwh_expr_bincalc(OPR_BIOR,wn,t1); 01795 wn = cwh_wrap_cvtl(wn,bt); 01796 01797 wn = cwh_expr_restore_arrayexp(wn,ae); 01798 cwh_stk_push(wn,WN_item); 01799 } 01800 01801 01802 /*============================================= 01803 * 01804 * cwh_expr_temp 01805 * 01806 * Return the address of a temp. If e_sz is 01807 * NULL or constant the temp depends on the TY, 01808 * and a temp is generated, otherwise an alloca 01809 * is issued and a preg returned with the address. 01810 * 01811 * If an array valued temp is needed, then the TY 01812 * should reflect this. e_sz is intepreted as the 01813 * size of an element, so if TY_size == 0, the 01814 * element size can stand in. 01815 * 01816 * If the temp is created within a parallel region 01817 * it should be marked as LOCAL in the pragma list 01818 * 01819 * Flag is PASSED/SAVED etc - typical for an address 01820 * 01821 *============================================= 01822 */ 01823 extern WN * 01824 cwh_expr_temp(TY_IDX ty, WN * e_sz, FLAG flag) 01825 { 01826 ST * st ; 01827 TY_IDX tp ; 01828 WN * wr ; 01829 WN * nl[1] ; 01830 WN * wn[1] ; 01831 BOOL va[1] ; 01832 WN *free_stmt; 01833 01834 PREG_det det; 01835 01836 if (e_sz == NULL && TY_size(ty) != 0) { 01837 01838 st = cwh_stab_temp_ST(ty,TY_name(ty)); 01839 cwh_expr_set_flags(st,flag); 01840 wr = cwh_addr_address_ST(st); 01841 01842 01843 } else if (WNOPR(e_sz) == OPR_INTCONST && TY_size(ty) != 0) { 01844 01845 st = cwh_stab_temp_ST(ty,TY_name(ty)); 01846 cwh_expr_set_flags(st,flag); 01847 wr = cwh_addr_address_ST(st); 01848 01849 } else { 01850 DevAssert((e_sz!=NULL),("NULL element size in cwh_expr_temp")); 01851 01852 if (TY_kind(ty) == KIND_ARRAY) 01853 wn[0] = cwh_types_size_WN(ty,e_sz); 01854 else 01855 wn[0] = e_sz ; 01856 01857 nl[0] = NULL; 01858 va[0] = TRUE; 01859 01860 /* pregs are assumed LOCAL by the MP lowerer */ 01861 01862 det = cwh_preg_next_preg(Pointer_Mtype,"concat_temp",NULL); 01863 wr = cwh_intrin_op(INTRN_F90_STACKTEMPALLOC,1,wn,nl,va,Pointer_Mtype); 01864 01865 tp = cwh_types_make_pointer_type(ty, FALSE); 01866 01867 cwh_addr_store_ST(det.preg_st,det.preg,tp,wr); 01868 01869 wr = cwh_addr_load_ST(det.preg_st,det.preg,tp); 01870 01871 /* Add call to free temp to defer list, set flags so it won't be moved before alloc */ 01872 01873 wn[0] = cwh_intrin_wrap_value_parm(WN_COPY_Tree(wr)); 01874 free_stmt = WN_Create_Intrinsic(OPC_VINTRINSIC_CALL,INTRN_F90_STACKTEMPFREE,1,wn); 01875 WN_Set_Call_Non_Parm_Ref(free_stmt); 01876 WN_Set_Call_Non_Parm_Mod(free_stmt); 01877 cwh_block_append_given_id(free_stmt,Defer_Block,FALSE); 01878 } 01879 01880 return(wr); 01881 } 01882 01883 /*=============================================== 01884 * 01885 * cwh_expr_temp_set_pragma 01886 * 01887 * If a temp is created within a parallel region 01888 * it may require a LOCAL pragma to be set in 01889 * the parallel region. 01890 * 01891 *=============================================== 01892 */ 01893 extern void 01894 cwh_expr_temp_set_pragma(ST *st) 01895 { 01896 cwh_block_add_to_enclosing_regions(WN_PRAGMA_LOCAL,st); 01897 } 01898 01899 /*=============================================== 01900 * 01901 * cwh_expr_str_operand 01902 * 01903 * Assumes stack top contains an STR_item; pops the 01904 * string marker and then returns the address and the 01905 * length of the string in the argument passed to the 01906 * routine. 01907 * 01908 *=============================================== 01909 */ 01910 01911 extern void 01912 cwh_expr_str_operand(W_node expr[2]) 01913 { 01914 WN * wn; 01915 01916 cwh_stk_pop_STR(); 01917 01918 wn = cwh_expr_operand(NULL); 01919 W_ty(expr[0]) = cwh_types_WN_TY(wn,FALSE); 01920 W_wn(expr[0]) = wn; 01921 01922 W_ty(expr[1]) = cwh_stk_get_TY(); 01923 W_wn(expr[1]) = cwh_expr_address(f_NONE); 01924 01925 } 01926 01927 /*=============================================== 01928 * 01929 * cwh_expr_set_flags 01930 * 01931 * set the requested flags on an ST. In 7.3, the 01932 * addr_passed flag is removed & the information 01933 * computed by wopt. 01934 * 01935 *=============================================== 01936 */ 01937 extern void 01938 cwh_expr_set_flags(ST *st, FLAG flag) 01939 { 01940 if (st != NULL) 01941 if ((ST_class(st) == CLASS_VAR) || 01942 (ST_class(st) == CLASS_FUNC)) { 01943 if (flag & f_T_SAVED) Set_ST_addr_saved(st); 01944 } 01945 } 01946 01947 /*=============================================== 01948 * 01949 * cwh_expr_dispose_of_char 01950 * 01951 * The CHAR intrinsic is converted to temp and 01952 * address of temp in the f90 lowerer. In some 01953 * circumstances we want the value immediately. 01954 * 01955 * Take the intrinsic op and PARM off the top, 01956 * and return the value. There may be an ARRAYEXP 01957 * in the way, as it would have a ARRAY argumnet 01958 * to the intrinsic. 01959 * 01960 *=============================================== 01961 */ 01962 extern WN * 01963 cwh_expr_dispose_of_char(WN * src) 01964 { 01965 WN * wn; 01966 WN * wn1; 01967 01968 if (WN_operator(src) == OPR_ARRAYEXP) { 01969 wn = WN_kid0(src); 01970 wn1 = cwh_expr_dispose_of_char(wn); 01971 if (wn != wn1) 01972 WN_kid0(src) = wn1; 01973 01974 } else if (WN_operator(src) == OPR_INTRINSIC_OP && 01975 WN_intrinsic(src) == INTRN_CHAR) { 01976 01977 wn = WN_kid0(src); 01978 WN_Delete(src); 01979 src = WN_kid0(wn); 01980 WN_Delete(wn); 01981 } 01982 return src; 01983 }