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: Process most of the intrinsic type nodes 00044 * 00045 * 00046 * 00047 * ==================================================================== 00048 * ==================================================================== 00049 */ 00050 00051 static char *source_file = __FILE__; 00052 00053 #ifdef _KEEP_RCS_ID 00054 #endif /* _KEEP_RCS_ID */ 00055 00056 /* sgi includes */ 00057 00058 #include "defs.h" 00059 #include "glob.h" 00060 #include "stab.h" 00061 #include "strtab.h" 00062 #include "erfe90.h" 00063 #include "errors.h" 00064 #include "config_targ.h" 00065 #include "wn.h" 00066 #include "wn_util.h" 00067 #include "const.h" 00068 #include "wintrinsic.h" 00069 #include "f90_utils.h" 00070 00071 /* Cray includes */ 00072 00073 #include "i_cvrt.h" 00074 00075 /* conversion includes */ 00076 00077 #include "cwh_defines.h" 00078 #include "cwh_addr.h" 00079 #include "cwh_block.h" 00080 #include "cwh_stk.h" 00081 #include "cwh_types.h" 00082 #include "cwh_expr.h" 00083 #include "cwh_stmt.h" 00084 #include "cwh_preg.h" 00085 #include "cwh_stab.h" 00086 #include "cwh_intrin.h" 00087 #include "cwh_intrin.i" 00088 00089 /* 00090 * Used by RANGET and RANSET and RTC and UNIT and LENGTH and GETPOS 00091 * and OMP_SET_LOCK, OMP_UNSET_LOCK, and OMP_TEST_LOCK 00092 */ 00093 static ST *ranget_st = NULL; 00094 static ST *ranset_st = NULL; 00095 static ST *rtc_st = NULL; 00096 static ST *unit_st = NULL; 00097 static ST *length_st = NULL; 00098 static ST *getpos_st = NULL; 00099 static ST *omp_set_lock_st=NULL; 00100 static ST *omp_unset_lock_st=NULL; 00101 static ST *omp_test_lock_st=NULL; 00102 00103 /*================================================================ 00104 * 00105 * cwh_intrin_get_return_value 00106 * 00107 * Copy the return value of a function into a PREG, and return a 00108 * load of that PREG. 00109 * 00110 *================================================================ 00111 */ 00112 static WN * 00113 cwh_intrin_get_return_value(TYPE_ID rtype, char *name ) 00114 { 00115 PREG_NUM rpreg; 00116 PREG_det rpreg_det; 00117 WN *wn; 00118 00119 rpreg_det = cwh_preg_next_preg (rtype,name,NULL); 00120 rpreg = rpreg_det.preg; 00121 wn = cwh_expr_operand(NULL); 00122 wn = WN_StidPreg(rtype,rpreg,wn); 00123 cwh_block_append(wn); 00124 wn = WN_LdidPreg(rtype,rpreg); 00125 return (wn); 00126 } 00127 00128 00129 /* Utility to get a t_enum number from an MTYPE */ 00130 static t_enum t_from_mtype(TYPE_ID ty) 00131 { 00132 t_enum t; 00133 t = t_BAD; 00134 switch (ty) { 00135 case MTYPE_I1: t = t_I1; break; 00136 case MTYPE_I2: t = t_I2; break; 00137 case MTYPE_I4: t = t_I4; break; 00138 case MTYPE_I8: t = t_I8; break; 00139 case MTYPE_F4: t = t_F4; break; 00140 case MTYPE_F8: t = t_F8; break; 00141 case MTYPE_FQ: t = t_FQ; break; 00142 case MTYPE_C4: t = t_C4; break; 00143 case MTYPE_C8: t = t_C8; break; 00144 case MTYPE_CQ: t = t_CQ; break; 00145 default: Fail_FmtAssertion(("Bad MTYPE %d seen in t_from_mtype"),ty); 00146 } 00147 return (t); 00148 } 00149 00150 /*================================================================ 00151 * 00152 * cwh_intrin_null_parm 00153 * 00154 * Create a VPARM node with 0 children. We need to do it this way, 00155 * because the Whirl node creation functions won't create a PARM 00156 * without children 00157 * 00158 *================================================================ 00159 */ 00160 static WN * 00161 cwh_intrin_null_parm(void) 00162 { 00163 WN *wn; 00164 00165 wn = WN_CreateParm(MTYPE_V,WN_Zerocon(MTYPE_I4),Be_Type_Tbl(MTYPE_V),0); 00166 return (wn); 00167 } 00168 00169 /*================================================================ 00170 * 00171 * cwh_intrin_make_intrinsic_symbol(char *name, TYPE_ID ty) 00172 * 00173 * Build an ST for a symbol used in a call. The name of the symbol will 00174 * be name, and the type will be function returning a ty. 00175 * 00176 *================================================================ 00177 */ 00178 extern 00179 ST * cwh_intrin_make_intrinsic_symbol(char *name, TYPE_ID bt) 00180 { 00181 ST *st; 00182 st = cwh_stab_mk_fn_0args(name, EXPORT_PREEMPTIBLE, GLOBAL_SYMTAB + 1, 00183 Be_Type_Tbl(bt)); 00184 return (st); 00185 } 00186 00187 /*=============================================== 00188 * 00189 * cwh_intrin_wrap_value_parm 00190 * 00191 * Wrap a by-value OPC_PARM around an argument 00192 * 00193 *=============================================== 00194 */ 00195 extern WN * 00196 cwh_intrin_wrap_value_parm(WN *w) 00197 { 00198 TYPE_ID t; 00199 WN *r; 00200 TY_IDX ty; 00201 00202 if (w == NULL) 00203 return (w); /* give me anything,but don't give me segmentation fault :-) */ 00204 00205 00206 if (WNOPR(w) == OPR_PARM) { 00207 return (w); 00208 } 00209 00210 t = WN_rtype(w); 00211 if (t == MTYPE_M) { 00212 /* we need to be more sophisticated so we can 00213 * get the precise type that belongs on the PARM node. 00214 */ 00215 ty = cwh_types_WN_TY(w,FALSE); 00216 } else { 00217 ty = Be_Type_Tbl(t); 00218 } 00219 00220 r = WN_CreateParm(t,w,ty,WN_PARM_BY_VALUE); 00221 return (r); 00222 } 00223 00224 /*=============================================== 00225 * 00226 * cwh_intrin_wrap_ref_parm 00227 * 00228 * Wrap a by-reference OPC_PARM around an argument 00229 * If the TY is provided, use that to form the PARM's 00230 * type, otherwise use the TY of the WN. 00231 * 00232 * The PARM's rty is always Pointer_Mtype. (Sometimes 00233 * we wrap a function result which gets a temp later 00234 * in the lowering ie: wa is not an address..) 00235 * 00236 *=============================================== 00237 */ 00238 extern WN * 00239 cwh_intrin_wrap_ref_parm(WN *wa, TY_IDX ty) 00240 { 00241 WN * wn ; 00242 00243 00244 if (ty == 0) 00245 ty = cwh_types_WN_TY(wa,TRUE); 00246 00247 wn = WN_CreateParm (Pointer_Mtype, 00248 wa, 00249 ty, 00250 WN_PARM_BY_REFERENCE); 00251 00252 return(wn); 00253 } 00254 00255 /*=============================================== 00256 * 00257 * cwh_intrin_wrap_char_parm 00258 * 00259 * Wrap a by-reference OPC_PARM around an argument 00260 * It's the address of a character object, so the 00261 * type of the OPC_PARM has to be a pointer to 00262 * a string of the correct length, and this is 00263 * created from the SZ argument. 00264 * 00265 *=============================================== 00266 */ 00267 extern WN * 00268 cwh_intrin_wrap_char_parm(WN *wa, WN *sz ) 00269 { 00270 WN * wn ; 00271 TY_IDX ty ; 00272 00273 00274 DevAssert((sz != NULL),("Bad PARM TY")); 00275 ty = cwh_types_ch_parm_TY(sz); 00276 00277 wn = cwh_intrin_wrap_ref_parm(wa,ty); 00278 00279 return(wn); 00280 } 00281 00282 /*=============================================== 00283 * 00284 * simple_intrinsic 00285 * 00286 * Helper routine for processing intrinsics 00287 * Does a lookup in the intrinsics table, and 00288 * builds either an intrinsic op or the appropriate 00289 * WHIRL node. There is an assumption the arguments 00290 * are passed by value. Temps for results would be 00291 * required otherwise. 00292 * 00293 *=============================================== 00294 */ 00295 static void 00296 simple_intrinsic(i_enum intrin, TYPE_ID bt, INT numargs, INT numpop) 00297 { 00298 OPCODE opc ; 00299 INTRINSIC intr; 00300 WN *k[3]; 00301 WN *wn ; 00302 INT i; 00303 TYPE_ID t; 00304 WN *ae=NULL; 00305 00306 DevAssert((numargs <= 3),("Can't handle that many arguments")); 00307 00308 intr = GET_ITAB_IOP(intrin,bt); 00309 opc = GET_ITAB_WOP(intrin,bt); 00310 00311 DevAssert((opc || intr),("Unsupported intr/ty combo")); 00312 00313 /* Remove spurious arguments */ 00314 00315 for (i = 0; i < numpop; i++) { 00316 WN_DELETE_Tree(cwh_expr_operand(NULL)); 00317 } 00318 00319 for (i = numargs-1; i >= 0; i--) 00320 k[i] = cwh_expr_operand(&ae); 00321 00322 /* Make sure types of arguments all match */ 00323 t = WN_rtype(k[0]); 00324 for (i = 1; i < numargs; i++) { 00325 if (WNRTY(k[i]) != t) { 00326 k[i] = cwh_convert_to_ty(k[i],t); 00327 00328 if (intr) 00329 k[i] = WN_CreateParm(t,k[i],Be_Type_Tbl(t),WN_PARM_BY_VALUE); 00330 } 00331 } 00332 00333 if (intr) 00334 wn = cwh_intrin_build(k,intr,bt,numargs); 00335 00336 else { 00337 switch (numargs) { 00338 case 1: 00339 wn = WN_CreateExp1(opc,k[0]); 00340 break; 00341 case 2: 00342 wn = WN_CreateExp2(opc,k[0],k[1]); 00343 break; 00344 case 3: 00345 wn = WN_CreateExp3(opc,k[0],k[1],k[2]); 00346 break; 00347 } 00348 } 00349 00350 wn = cwh_expr_restore_arrayexp(wn,ae); 00351 cwh_stk_push(wn,WN_item); 00352 } 00353 00354 /*=============================================== 00355 * 00356 * simple_intrinsic_nt 00357 * 00358 * Does a lookup in the intrinsics table, and 00359 * builds either an intrinsic op or 00360 * the appropriate WHIRL node. The result TY 00361 * is that of the first operand ie: last of 00362 * those read from the stack. 00363 * 00364 * Args passed by value. 00365 * 00366 *=============================================== 00367 */ 00368 static void 00369 simple_intrinsic_nt(i_enum intrin, INT numargs, INT numpop) 00370 { 00371 OPCODE opc ; 00372 INTRINSIC intr; 00373 WN *k[3]; 00374 WN *wn ; 00375 INT i; 00376 TYPE_ID bt; 00377 WN *ae=NULL; 00378 00379 DevAssert((numargs <=3),("Can't handle that many arguments")); 00380 /* Remove spurious arguments */ 00381 for (i = 0; i < numpop; i++) { 00382 WN_DELETE_Tree(cwh_expr_operand(NULL)); 00383 } 00384 00385 for (i = numargs-1; i >= 0; i--) { 00386 k[i] = cwh_expr_operand(&ae); 00387 } 00388 00389 bt = WN_rtype(k[0]); 00390 00391 intr = GET_ITAB_IOP(intrin,bt); 00392 opc = GET_ITAB_WOP(intrin,bt); 00393 00394 DevAssert((opc || intr),("Unsupported intr/ty combo")); 00395 00396 if (intr) 00397 wn = cwh_intrin_build(k,intr,bt,numargs); 00398 00399 else { 00400 switch (numargs) { 00401 case 1: 00402 wn = WN_CreateExp1(opc,k[0]); 00403 break; 00404 case 2: 00405 wn = WN_CreateExp2(opc,k[0],k[1]); 00406 break; 00407 case 3: 00408 wn = WN_CreateExp3(opc,k[0],k[1],k[2]); 00409 break; 00410 } 00411 } 00412 00413 wn = cwh_expr_restore_arrayexp(wn,ae); 00414 cwh_stk_push(wn,WN_item); 00415 } 00416 00417 /*=============================================== 00418 * 00419 * do_simple & do_simple_nt 00420 * 00421 * macro definitions to invoke utility routines 00422 * simple_intrinsic or simple_intrinsic_nt. If 00423 * the type of the result is inferred from the 00424 * intrinsic table use do_simple, if from the 00425 * first operand, use do_simple_nt. 00426 * 00427 *=============================================== 00428 */ 00429 #define do_simple(name,numargs,numpop) void fei_##name(TYPE type) \ 00430 {simple_intrinsic(i_##name,TY_mtype(cast_to_TY(t_TY(type))),numargs,numpop);} 00431 00432 #define do_simple_nt(name,numargs,numpop) void fei_##name(void) \ 00433 {simple_intrinsic_nt(i_##name,numargs,numpop);} 00434 00435 do_simple(acos,1,0) 00436 do_simple(asin,1,0) 00437 do_simple(atan,1,0) 00438 do_simple(atan2,2,0) 00439 do_simple(conjg,1,0) 00440 do_simple(cos,1,0) 00441 do_simple(cosh,1,0) 00442 do_simple(exp,1,0) 00443 do_simple_nt(fraction,1,0) 00444 do_simple(ishftc,3,0) 00445 do_simple(log,1,0) 00446 do_simple(log10,1,0) 00447 do_simple(mod,2,0) 00448 do_simple(modulo,2,0) 00449 do_simple(nextafter,2,0) 00450 do_simple(rrspace,1,1) 00451 do_simple(sin,1,0) 00452 do_simple(sinh,1,0) 00453 do_simple(space,1,1) 00454 do_simple(sqrt,1,0) 00455 do_simple(tan,1,0) 00456 do_simple(tanh,1,0) 00457 00458 do_simple(acosd,1,0) 00459 do_simple(asind,1,0) 00460 do_simple(atand,1,0) 00461 do_simple(atan2d,2,0) 00462 do_simple(cosd,1,0) 00463 do_simple(sind,1,0) 00464 do_simple(tand,1,0) 00465 00466 00467 /******************************************************************** 00468 00469 Unfortunately, we need to hand-generate most of these following 00470 00471 *********************************************************************/ 00472 00473 /*=============================================== 00474 * 00475 * fei_complex 00476 * 00477 * CMPLX intrinsic. A special case because 00478 * result and operands are not same type 00479 * and we might need a conversion. Integer 00480 * constant arguments have already been converted 00481 * to floats. 00482 * 00483 *=============================================== 00484 */ 00485 void 00486 fei_complex(TYPE type) 00487 { 00488 TYPE_ID br ; 00489 TYPE_ID bt ; 00490 WN *k[2] ; 00491 WN * wn ; 00492 INT i ; 00493 WN *ae=NULL; 00494 00495 OPCODE opc ; 00496 00497 k[1] = cwh_expr_operand(&ae); 00498 k[0] = cwh_expr_operand(&ae); 00499 br = TY_mtype(cast_to_TY(t_TY(type))) ; 00500 opc = GET_ITAB_WOP(i_complex,br); 00501 00502 for (i = 0 ; i < 2 ; i ++ ) { 00503 00504 switch (br) { 00505 case MTYPE_C4: bt = MTYPE_F4; break; 00506 case MTYPE_C8: bt = MTYPE_F8; break; 00507 case MTYPE_CQ: bt = MTYPE_FQ; break; 00508 } 00509 00510 k[i] = cwh_convert_to_ty(k[i],bt); 00511 } 00512 00513 wn = WN_CreateExp2(opc,k[0],k[1]); 00514 wn = cwh_expr_restore_arrayexp(wn,ae); 00515 cwh_stk_push(wn,WN_item); 00516 } 00517 00518 /*=============================================== 00519 * 00520 * fei_abs 00521 * 00522 * ABS intrinsic. A special case because 00523 * operator depends on result and argument. 00524 * If the argument is complex, then pick 00525 * up a special operator, otherwise look 00526 * up in the intrinsic table. Argument is 00527 * TOS so pop & examine. 00528 * 00529 *=============================================== 00530 */ 00531 void 00532 fei_abs(TYPE type) 00533 { 00534 TYPE_ID ba ; 00535 TYPE_ID br ; 00536 TY_IDX ty ; 00537 WN *wn ; 00538 WN *ae=NULL; 00539 00540 INTRINSIC intr; 00541 00542 wn = cwh_expr_operand(&ae); 00543 ty = cwh_types_WN_TY(wn,FALSE); 00544 ty = cwh_types_scalar_TY(ty); 00545 ba = TY_mtype(ty); 00546 br = TY_mtype(cast_to_TY(t_TY(type))) ; 00547 00548 if (MTYPE_is_complex(ba)) { 00549 switch(ba) { 00550 case MTYPE_C4: intr = INTRN_F4C4ABS ; break; 00551 case MTYPE_C8: intr = INTRN_F8C8ABS ; break; 00552 case MTYPE_CQ: intr = INTRN_FQCQABS ; break; 00553 00554 } 00555 wn = cwh_intrin_build(&wn,intr,br,1); 00556 wn = cwh_expr_restore_arrayexp(wn,ae); 00557 cwh_stk_push(wn,WN_item); 00558 00559 } else { 00560 wn = cwh_wrap_cvtl(wn,br); 00561 wn = cwh_expr_restore_arrayexp(wn,ae); 00562 cwh_stk_push(wn,WN_item); 00563 simple_intrinsic(i_abs,br,1,0); 00564 } 00565 } 00566 00567 /* 00568 * Cotangent 00569 */ 00570 00571 void 00572 fei_cot(TYPE type) 00573 { 00574 WN *one, *wn; 00575 00576 fei_tan(type); 00577 wn = cwh_expr_operand(NULL); 00578 one = WN_Intconst(MTYPE_I4,1); 00579 cwh_stk_push(one,WN_item); 00580 cwh_stk_push(wn,WN_item); 00581 fei_div(type); 00582 } 00583 00584 void 00585 fei_exponentiate(TYPE type) 00586 { 00587 00588 TYPE_ID bt, rt; 00589 TYPE_ID et; 00590 INTRINSIC intr; 00591 WN *k[2]; 00592 WN *wn ; 00593 WN *base, *exp; 00594 WN *ae=NULL; 00595 00596 00597 bt = TY_mtype(cast_to_TY(t_TY(type))) ; 00598 exp = cwh_expr_operand(&ae); 00599 base = cwh_get_typed_operand(bt,&ae); 00600 00601 et = WN_rtype(exp); 00602 00603 if (et == MTYPE_I4) { 00604 switch (bt) { 00605 case MTYPE_I1: 00606 case MTYPE_I2: 00607 case MTYPE_I4: 00608 intr = INTRN_I4EXPEXPR; break; 00609 case MTYPE_I8: intr = INTRN_I8EXPEXPR; break; 00610 case MTYPE_F4: intr = INTRN_F4I4EXPEXPR; break; 00611 case MTYPE_F8: intr = INTRN_F8I4EXPEXPR; break; 00612 case MTYPE_FQ: intr = INTRN_FQI4EXPEXPR; break; 00613 case MTYPE_C4: intr = INTRN_C4I4EXPEXPR; break; 00614 case MTYPE_C8: intr = INTRN_C8I4EXPEXPR; break; 00615 case MTYPE_CQ: intr = INTRN_CQI4EXPEXPR; break; 00616 } 00617 } else if (et == MTYPE_I8) { 00618 switch (bt) { 00619 case MTYPE_I1: 00620 case MTYPE_I2: 00621 case MTYPE_I4: 00622 case MTYPE_I8: 00623 intr = INTRN_I8EXPEXPR; break; 00624 case MTYPE_F4: intr = INTRN_F4I8EXPEXPR; break; 00625 case MTYPE_F8: intr = INTRN_F8I8EXPEXPR; break; 00626 case MTYPE_FQ: intr = INTRN_FQI8EXPEXPR; break; 00627 case MTYPE_C4: intr = INTRN_C4I8EXPEXPR; break; 00628 case MTYPE_C8: intr = INTRN_C8I8EXPEXPR; break; 00629 case MTYPE_CQ: intr = INTRN_CQI8EXPEXPR; break; 00630 } 00631 } else { 00632 exp = cwh_convert_to_ty(exp,bt); 00633 switch (bt) { 00634 case MTYPE_F4: intr = INTRN_F4EXPEXPR; break; 00635 case MTYPE_F8: intr = INTRN_F8EXPEXPR; break; 00636 case MTYPE_FQ: intr = INTRN_FQEXPEXPR; break; 00637 case MTYPE_C4: intr = INTRN_C4EXPEXPR; break; 00638 case MTYPE_C8: intr = INTRN_C8EXPEXPR; break; 00639 case MTYPE_CQ: intr = INTRN_CQEXPEXPR; break; 00640 } 00641 } 00642 00643 rt = WN_rtype(base); 00644 k[0] = base; 00645 k[1] = exp ; 00646 wn = cwh_intrin_build(k,intr,rt,2); 00647 00648 wn = cwh_expr_restore_arrayexp(wn,ae); 00649 cwh_stk_push(wn,WN_item); 00650 } 00651 00652 /*=============================================== 00653 * 00654 * fei_round 00655 * 00656 * ANINT & NINT intrinsic variants. Select intrinsic 00657 * op based on type, and push the op on the stack. 00658 * Although some are called by ref, some by value we 00659 * pass a by-value intrinsic and the f90 lowerer patches 00660 * it up to the correct ref/value. 00661 * 00662 *=============================================== 00663 */ 00664 void 00665 fei_round(TYPE type) 00666 { 00667 TYPE_ID bt,rt ; 00668 OPCODE opc ; 00669 INTRINSIC intr; 00670 WN *k[2]; 00671 WN *wn ; 00672 WN *ae=NULL; 00673 00674 rt = TY_mtype(cast_to_TY(t_TY(type))); 00675 00676 if(MTYPE_is_float(rt)) { 00677 k[0] = cwh_expr_operand(&ae); 00678 bt = WNRTY(k[0]); 00679 opc = cwh_make_typed_opcode(OPR_INTRINSIC_OP, bt, MTYPE_V); 00680 k[0] = cwh_intrin_wrap_value_parm(k[0]); 00681 00682 switch (bt) { 00683 case MTYPE_F4: intr = INTRN_F4ANINT; break; 00684 case MTYPE_F8: intr = INTRN_F8ANINT; break; 00685 case MTYPE_FQ: intr = INTRN_FQANINT; break; 00686 } 00687 } else { 00688 00689 k[0] = cwh_expr_operand(&ae); 00690 bt = WNRTY(k[0]); 00691 k[0] = cwh_intrin_wrap_value_parm(k[0]); 00692 00693 switch (rt) { 00694 case MTYPE_I1: 00695 case MTYPE_I2: 00696 case MTYPE_I4: 00697 opc = cwh_make_typed_opcode(OPR_INTRINSIC_OP, MTYPE_I4, MTYPE_V); 00698 switch (bt) { 00699 case MTYPE_F4: intr = INTRN_I4F4NINT; break; 00700 case MTYPE_F8: intr = INTRN_I4F8IDNINT; break; 00701 case MTYPE_FQ: intr = INTRN_I4FQIQNINT; break; 00702 } 00703 break; 00704 00705 case MTYPE_I8: 00706 opc = cwh_make_typed_opcode(OPR_INTRINSIC_OP, MTYPE_I8, MTYPE_V); 00707 switch (bt) { 00708 case MTYPE_F4: intr = INTRN_I8F4NINT; break; 00709 case MTYPE_F8: intr = INTRN_I8F8IDNINT; break; 00710 case MTYPE_FQ: intr = INTRN_I8FQIQNINT; break; 00711 } 00712 break; 00713 } 00714 } 00715 00716 wn = WN_Create_Intrinsic(opc,intr,1,k); 00717 if(MTYPE_is_float(rt)) { 00718 wn = cwh_convert_to_ty(wn,rt); 00719 } else { 00720 wn = cwh_wrap_cvtl(wn,rt); 00721 } 00722 00723 wn = cwh_expr_restore_arrayexp(wn,ae); 00724 cwh_stk_push_typed(wn,WN_item,Be_Type_Tbl(rt)); 00725 } 00726 00727 /*=============================================== 00728 * 00729 * fei_trunc 00730 * 00731 * AINT intrinsic variants. Needed because of KIND argument. 00732 * 00733 *=============================================== 00734 */ 00735 void 00736 fei_trunc(TYPE type) 00737 { 00738 TYPE_ID bt,rt ; 00739 INTRINSIC intr; 00740 WN *k[1]; 00741 WN *wn ; 00742 WN *ae=NULL; 00743 00744 rt = TY_mtype(cast_to_TY(t_TY(type))); 00745 k[0] = cwh_expr_operand(&ae); 00746 bt = WNRTY(k[0]); 00747 k[0] = cwh_intrin_wrap_value_parm(k[0]); 00748 00749 intr = GET_ITAB_IOP(i_trunc,bt); 00750 00751 DevAssert((intr),("Unsupported intr/ty combo")); 00752 00753 wn = cwh_intrin_build(k,intr,bt,1); 00754 wn = cwh_convert_to_ty(wn,rt); 00755 00756 wn = cwh_expr_restore_arrayexp(wn,ae); 00757 cwh_stk_push(wn,WN_item); 00758 } 00759 00760 void fei_scale(TYPE type) 00761 { 00762 TYPE_ID bt ; 00763 INTRINSIC intr; 00764 WN *k[2]; 00765 WN *wn ; 00766 WN *ae=NULL; 00767 00768 k[1] = cwh_get_typed_operand(MTYPE_I4,&ae); 00769 k[0] = cwh_expr_operand(&ae); 00770 bt = WN_rtype(k[0]); 00771 intr = GET_ITAB_IOP(i_scale,bt); 00772 00773 wn = cwh_intrin_build(k,intr,bt,2); 00774 wn = cwh_expr_restore_arrayexp(wn,ae); 00775 cwh_stk_push(wn,WN_item); 00776 } 00777 00778 void fei_near(TYPE type) 00779 { 00780 TYPE_ID bt; 00781 INTRINSIC intr; 00782 WN *k[2]; 00783 WN *wn; 00784 WN *ae=NULL; 00785 00786 WN_DELETE_Tree(cwh_expr_operand(NULL)); 00787 k[1] = cwh_expr_operand(&ae); 00788 k[0] = cwh_expr_operand(&ae); 00789 bt = WN_rtype(k[0]); 00790 intr = GET_ITAB_IOP(i_near,bt); 00791 00792 wn = cwh_intrin_build(k,intr,bt,2); 00793 wn = cwh_expr_restore_arrayexp(wn,ae); 00794 cwh_stk_push(wn,WN_item); 00795 } 00796 00797 00798 void fei_set_exponent(TYPE type) 00799 { 00800 TYPE_ID bt ; 00801 INTRINSIC intr; 00802 WN *k[2]; 00803 WN *wn ; 00804 WN *ae=NULL; 00805 00806 k[1] = cwh_get_typed_operand(MTYPE_I4,&ae); 00807 k[0] = cwh_expr_operand(&ae); 00808 bt = WN_rtype(k[0]); 00809 00810 intr = GET_ITAB_IOP(i_set_exponent,bt); 00811 wn = cwh_intrin_build(k,intr,bt,2); 00812 wn = cwh_expr_restore_arrayexp(wn,ae); 00813 cwh_stk_push(wn,WN_item); 00814 } 00815 00816 void fei_exponent(TYPE type) 00817 { 00818 TYPE_ID bt,rt; 00819 INTRINSIC intr; 00820 WN *k[1]; 00821 WN *wn ; 00822 WN *ae=NULL; 00823 00824 rt = TY_mtype(cast_to_TY(t_TY(type))); 00825 k[0] = cwh_expr_operand(&ae); 00826 bt = WN_rtype(k[0]); 00827 00828 intr = GET_ITAB_IOP(i_exponent,bt); 00829 wn = cwh_intrin_build(k,intr,rt,1); 00830 wn = cwh_expr_restore_arrayexp(wn,ae); 00831 cwh_stk_push(wn,WN_item); 00832 } 00833 00834 00835 /* 00836 * Inline the Fortran DIM intrinsic 00837 */ 00838 void fei_pos_diff(TYPE type) 00839 { 00840 WN *zero; 00841 fei_minus(type); 00842 zero = WN_Intconst(MTYPE_I4,0); 00843 cwh_stk_push(zero,WN_item); 00844 fei_max(2,type); 00845 } 00846 00847 00848 /* 00849 * Inline the SIGN intrinsic 00850 */ 00851 void fei_sign_xfer(TYPE type) 00852 { 00853 WN *a, *aneg, *b; 00854 WN *ae=NULL; 00855 00856 b = cwh_expr_operand(&ae); 00857 00858 fei_abs(type); 00859 a = cwh_expr_operand(&ae); 00860 cwh_stk_push(WN_COPY_Tree(a),WN_item); 00861 fei_uminus(type); 00862 aneg = cwh_expr_operand(&ae); 00863 00864 /* If B > 0, return A else return -A */ 00865 cwh_stk_push(b,WN_item); 00866 cwh_stk_push(WN_Zerocon(WN_rtype(b)),WN_item); 00867 fei_ge(type); 00868 b = cwh_expr_operand(&ae); 00869 cwh_stk_push(a,WN_item); 00870 cwh_stk_push(aneg,WN_item); 00871 b = cwh_expr_restore_arrayexp(b,ae); 00872 cwh_stk_push(b,WN_item); 00873 fei_select(type); 00874 } 00875 00876 /* 00877 * Inline the IEEE SIGN intrinsic 00878 */ 00879 void fei_ieee_sign_xfer(TYPE type) 00880 { 00881 WN *a, *b; 00882 WN *ae=NULL; 00883 TYPE_ID rt,it,bt; 00884 00885 rt = TY_mtype(cast_to_TY(t_TY(type))); 00886 if (rt == MTYPE_FQ) { 00887 fei_sign_xfer(type); 00888 return; 00889 } else if (rt == MTYPE_F8) { 00890 it = MTYPE_I8; 00891 } else { 00892 it = MTYPE_I4; 00893 } 00894 00895 b = cwh_expr_operand(&ae); 00896 bt = WNRTY(b); 00897 if (bt == MTYPE_F4) { 00898 b = WN_Tas(MTYPE_I4,Be_Type_Tbl(MTYPE_I4),b); 00899 b = WN_Lshr(MTYPE_I4,b,WN_Intconst(MTYPE_I4,31)); 00900 } else if (bt == MTYPE_F8) { 00901 b = WN_Tas(MTYPE_I8,Be_Type_Tbl(MTYPE_I8),b); 00902 b = WN_Lshr(MTYPE_I8,b,WN_Intconst(MTYPE_I8,63)); 00903 } else { 00904 /* FQ */ 00905 b = WN_LT(bt,b,WN_Zerocon(bt)); 00906 } 00907 00908 /* At this point B is either 0 or 1, and is either a 64 bit or a 32 bit integer */ 00909 /* Get it in the right position for Or'ing it in */ 00910 bt = WNRTY(b); 00911 if (MTYPE_bit_size(bt) == MTYPE_bit_size(rt)) { 00912 b = WN_Shl(bt,b,WN_Intconst(MTYPE_I4,MTYPE_bit_size(bt)-1)); 00913 } else if (MTYPE_bit_size(bt) > MTYPE_bit_size(rt)) { 00914 /* bt must be I8, rt, F4 */ 00915 b = WN_Shl(MTYPE_I4,b,WN_Intconst(MTYPE_I4,31)); 00916 } else { 00917 /* bt must be I4, rt, F8 */ 00918 b = WN_Shl(MTYPE_I8,b,WN_Intconst(MTYPE_I4,63)); 00919 } 00920 00921 /* Get ABS(A) */ 00922 fei_abs(type); 00923 a = cwh_expr_operand(&ae); 00924 00925 /* Convert it to an integer and or with the sign bit */ 00926 a = WN_Tas(it,Be_Type_Tbl(it),a); 00927 a = cwh_expr_bincalc(OPR_BIOR,a,b); 00928 00929 /* Convert it back to a real */ 00930 a = WN_Tas(rt,Be_Type_Tbl(rt),a); 00931 00932 a = cwh_expr_restore_arrayexp(a,ae); 00933 cwh_stk_push(a,WN_item); 00934 } 00935 00936 static void cwh_ceiling_floor(TYPE type, OPERATOR opr) 00937 { 00938 00939 TYPE_ID bt; 00940 TYPE_ID rt; 00941 OPCODE opc ; 00942 WN *k; 00943 WN *wn ; 00944 WN *ae=NULL; 00945 00946 k = cwh_expr_operand(&ae); 00947 bt = WN_rtype(k); 00948 rt = TY_mtype(cast_to_TY(t_TY(type))); 00949 00950 opc = cwh_make_typed_opcode(opr, rt, bt); 00951 wn = WN_CreateExp1 ( opc, k) ; 00952 00953 wn = cwh_expr_restore_arrayexp(wn,ae); 00954 cwh_stk_push(wn,WN_item); 00955 } 00956 00957 void fei_ceiling (TYPE type) 00958 { 00959 cwh_ceiling_floor(type, OPR_CEIL); 00960 } 00961 00962 void fei_floor (TYPE type) 00963 { 00964 cwh_ceiling_floor(type, OPR_FLOOR); 00965 } 00966 00967 00968 /*================================================================ 00969 * 00970 * cwh_do_tranformational 00971 * 00972 * Utility to build transformationals 00973 * 00974 * intrn - intrinsic to build 00975 * numargs - number of arguments to pop 00976 * rtype - the type of the returned value. 00977 * is_numeric - if TRUE, use the type from rtype to make up the type of the intrinsic op, 00978 * otherwise, use the type of the first argument. 00979 * cvt_to_rtype - if TRUE, all arguments are first converetd to the return type 00980 * 00981 *================================================================ 00982 */ 00983 #define MAXARGS 6 00984 00985 static void 00986 cwh_do_tranformational(INTRINSIC intrn, INT numargs, TYPE rtype, BOOL is_numeric, 00987 BOOL cvt_to_rtype) 00988 { 00989 WN * args[MAXARGS]; 00990 WN *wn; 00991 WN *charlen; 00992 OPCODE op; 00993 INT i; 00994 BOOL is_char; 00995 TY_IDX str_ty; 00996 TY_IDX p_ty; 00997 TY_IDX rty; 00998 TYPE_ID type_from_first; 00999 TYPE_ID result_type; 01000 01001 rty = cast_to_TY(t_TY(rtype)); 01002 result_type = TY_mtype(rty); 01003 01004 is_char = FALSE; 01005 for (i=numargs-1; i >= 0; i--) { 01006 01007 if (cwh_stk_get_class() == STR_item) { 01008 is_char = TRUE; 01009 01010 cwh_stk_pop_STR(); 01011 charlen = cwh_expr_operand(NULL); 01012 str_ty = cwh_stk_get_TY(); 01013 args[i] = cwh_expr_address(f_NONE); 01014 01015 if (TY_kind(str_ty) == KIND_POINTER) { 01016 p_ty = str_ty; 01017 str_ty = TY_pointed(p_ty); 01018 01019 } else 01020 p_ty = cwh_types_make_pointer_type(str_ty, FALSE); 01021 01022 if (WN_operator(args[i]) != OPR_INTRINSIC_OP) { 01023 args[i] = WN_CreateMload(0,p_ty,args[i],WN_COPY_Tree(charlen)); 01024 } else { 01025 WN_set_opcode(args[i],OPC_MINTRINSIC_OP); 01026 } 01027 args[i] = WN_CreateParm(MTYPE_M,args[i],str_ty,WN_PARM_BY_VALUE); 01028 01029 } else { 01030 args[i] = cwh_expr_operand(NULL); 01031 if (!args[i]) { 01032 args[i] = cwh_intrin_null_parm(); 01033 } else { 01034 if (cvt_to_rtype) { 01035 args[i] = cwh_convert_to_ty(args[i],result_type); 01036 } 01037 args[i] = cwh_intrin_wrap_value_parm(args[i]); 01038 } 01039 } 01040 } 01041 01042 if (is_char) { 01043 type_from_first = Pointer_Mtype; 01044 op = cwh_make_typed_opcode(OPR_INTRINSIC_OP, Pointer_Mtype, MTYPE_V); 01045 } else { 01046 type_from_first = result_type; 01047 if (is_numeric) { 01048 op = OPCODE_make_op(OPR_INTRINSIC_OP, result_type, MTYPE_V); 01049 } else { 01050 op = OPCODE_make_op(OPR_INTRINSIC_OP, WNRTY(args[0]), MTYPE_V); 01051 } 01052 } 01053 01054 wn = WN_Create_Intrinsic(op,intrn,numargs,args); 01055 01056 # if 0 01057 if (is_numeric) { 01058 wn = cwh_wrap_cvtl(wn,type_from_first); 01059 } 01060 wn = F90_Wrap_ARREXP(wn); 01061 # endif 01062 01063 if (is_char) { 01064 cwh_stk_push_STR(charlen,wn,str_ty,WN_item); /* assumes type_from_first */ 01065 } else { 01066 cwh_stk_push_typed(wn,WN_item,rty); 01067 } 01068 return; 01069 } 01070 01071 #define do_transformational(name,intrn,numargs,is_numeric) void name(TYPE rtype) \ 01072 {cwh_do_tranformational(intrn,numargs,rtype,is_numeric,FALSE);} 01073 01074 #define do_transformational_cvt(name,intrn,numargs,is_numeric) void name(TYPE rtype) \ 01075 {cwh_do_tranformational(intrn,numargs,rtype,is_numeric,TRUE);} 01076 01077 do_transformational(fei_spread,INTRN_SPREAD,3,FALSE) 01078 do_transformational(fei_transpose,INTRN_TRANSPOSE,1,FALSE) 01079 do_transformational(fei_all,INTRN_ALL,2,TRUE) 01080 do_transformational(fei_any,INTRN_ANY,2,TRUE) 01081 do_transformational(fei_product,INTRN_PRODUCT,3,TRUE) 01082 do_transformational(fei_sum,INTRN_SUM,3,TRUE) 01083 do_transformational(fei_maxval,INTRN_MAXVAL,3,TRUE) 01084 do_transformational(fei_minval,INTRN_MINVAL,3,TRUE) 01085 do_transformational(fei_maxloc,INTRN_MAXLOC,2,TRUE) 01086 do_transformational(fei_minloc,INTRN_MINLOC,2,TRUE) 01087 do_transformational(fei__maxloc,INTRN_MAXLOC,3,TRUE) 01088 do_transformational(fei__minloc,INTRN_MINLOC,3,TRUE) 01089 do_transformational(fei_pack,INTRN_PACK,3,FALSE) 01090 do_transformational(fei_unpack,INTRN_UNPACK,3,FALSE) 01091 do_transformational(fei_cshift,INTRN_CSHIFT,3,FALSE) 01092 do_transformational(fei_eoshift,INTRN_EOSHIFT,4,FALSE) 01093 01094 /*================================================================ 01095 * 01096 * fei_matmul 01097 * 01098 * Do matrix multiply 01099 * 01100 *================================================================ 01101 */ 01102 01103 void 01104 fei_matmul(TYPE rtype) 01105 { 01106 WN * args[2]; 01107 WN * wn; 01108 OPCODE op; 01109 INT i; 01110 TY_IDX rty; 01111 TYPE_ID result_type; 01112 01113 rty = cast_to_TY(t_TY(rtype)); 01114 result_type = TY_mtype(rty); 01115 01116 for (i=1; i >= 0; i--) { 01117 args[i] = cwh_expr_operand(NULL); 01118 args[i] = cwh_convert_to_ty(args[i],result_type); 01119 args[i] = cwh_intrin_wrap_value_parm(args[i]); 01120 } 01121 01122 if (TY_is_logical(rty)) { 01123 op = OPCODE_make_op(OPR_INTRINSIC_OP, MTYPE_B, MTYPE_V); 01124 } else { 01125 op = OPCODE_make_op(OPR_INTRINSIC_OP, result_type, MTYPE_V); 01126 } 01127 01128 wn = WN_Create_Intrinsic(op,INTRN_MATMUL,2,args); 01129 if (!TY_is_logical(rty)) { 01130 wn = cwh_wrap_cvtl(wn,result_type); 01131 } 01132 wn = F90_Wrap_ARREXP(wn); 01133 01134 cwh_stk_push_typed(wn,WN_item,rty); 01135 return; 01136 } 01137 01138 01139 01140 void 01141 fei_dot_product(TYPE rtype) 01142 { 01143 WN *arg0,*arg1; 01144 WN *intr_args[3]; 01145 WN *wn; 01146 OPCODE op,mpy_op; 01147 INTRINSIC intr; 01148 WN *ae=NULL; 01149 TY_IDX rty; 01150 TYPE_ID ty; 01151 01152 rty = cast_to_TY(t_TY(rtype)); 01153 ty = TY_mtype(rty); 01154 01155 arg1 = cwh_expr_operand(&ae); 01156 arg0 = cwh_expr_operand(&ae); 01157 arg0 = cwh_convert_to_ty(arg0,ty); 01158 arg1 = cwh_convert_to_ty(arg1,ty); 01159 01160 op = cwh_make_typed_opcode(OPR_INTRINSIC_OP, ty, MTYPE_V); 01161 mpy_op = cwh_make_typed_opcode(OPR_MPY,ty,MTYPE_V); 01162 01163 if (MTYPE_is_complex(ty)) { 01164 /* Need to conjugate arg0 */ 01165 if (ty == MTYPE_C4) { 01166 intr = INTRN_C4CONJG; 01167 } else if (ty == MTYPE_C8) { 01168 intr = INTRN_C8CONJG; 01169 } else { 01170 intr = INTRN_CQCONJG; 01171 } 01172 arg0 = cwh_intrin_wrap_value_parm(arg0); 01173 arg0 = WN_Create_Intrinsic(op,intr,1,&arg0); 01174 } 01175 01176 arg0 = WN_CreateExp2(mpy_op,arg0,arg1); 01177 arg0 = cwh_expr_restore_arrayexp(arg0,ae); 01178 intr_args[0] = cwh_intrin_wrap_value_parm(arg0); 01179 intr_args[1] = cwh_intrin_null_parm(); 01180 intr_args[2] = cwh_intrin_null_parm(); 01181 wn = WN_Create_Intrinsic(op,INTRN_SUM,3,intr_args); 01182 wn = cwh_wrap_cvtl(wn,ty); 01183 01184 cwh_stk_push_typed(wn,WN_item,rty); 01185 return; 01186 } 01187 01188 /*=============================================== 01189 * 01190 * fei_dot_product_logical 01191 * 01192 * Do DOT_PRODUCT intrinsic for logicals. TOS has 01193 * a pair of operands, and destination below. 01194 * Setup the ANY intrinsic to be the result of the 01195 * logical AND of the operands. & push the result 01196 * for fei_store. 01197 * 01198 *=============================================== 01199 */ 01200 void 01201 fei_dot_product_logical(TYPE rtype) 01202 { 01203 WN *arg0,*arg1; 01204 WN *intr_args[2]; 01205 WN *wn; 01206 OPCODE op ; 01207 WN *ae=NULL; 01208 01209 01210 TYPE_ID ty; 01211 01212 arg1 = cwh_expr_operand(&ae); 01213 arg0 = cwh_expr_operand(&ae); 01214 ty = cwh_get_highest_type(arg0,arg1); 01215 arg0 = cwh_convert_to_ty(arg0,ty); 01216 arg1 = cwh_convert_to_ty(arg1,ty); 01217 01218 op = cwh_make_typed_opcode(OPR_INTRINSIC_OP, ty, MTYPE_V); 01219 01220 arg0 = WN_CreateExp2(OPC_I4LAND,arg0,arg1); 01221 arg0 = cwh_expr_restore_arrayexp(arg0,ae); 01222 intr_args[0] = cwh_intrin_wrap_value_parm(arg0); 01223 intr_args[1] = cwh_intrin_null_parm(); 01224 wn = WN_Create_Intrinsic(op,INTRN_ANY,2,intr_args); 01225 01226 cwh_stk_push_typed(wn,WN_item,cast_to_TY(t_TY(rtype))); 01227 return; 01228 } 01229 01230 void 01231 fei_count(TYPE type) 01232 { 01233 WN *args[3]; 01234 WN *wn; 01235 OPCODE op; 01236 TYPE_ID ty; 01237 WN *ae=NULL; 01238 01239 args[1] = cwh_expr_operand(NULL); 01240 args[0] = cwh_expr_operand(&ae); 01241 if (!args[1]) { 01242 args[1] = cwh_intrin_wrap_value_parm(WN_Zerocon(MTYPE_I4)); 01243 } else { 01244 args[1] = cwh_intrin_wrap_value_parm(args[1]); 01245 } 01246 args[2] = cwh_intrin_wrap_value_parm(WN_Intconst(MTYPE_I4,1)); 01247 01248 /* Turn this into SUM(ARRAY.NE.0,...) */ 01249 ty = WN_rtype(args[0]); 01250 if (ty != MTYPE_B) { 01251 op = cwh_make_typed_opcode(OPR_NE,MTYPE_I4,ty); 01252 args[0] = WN_CreateExp2(op,args[0],WN_Zerocon(ty)); 01253 } 01254 args[0] = cwh_expr_restore_arrayexp(args[0],ae); 01255 args[0] = cwh_intrin_wrap_value_parm(args[0]); 01256 01257 op = cwh_make_typed_opcode(OPR_INTRINSIC_OP, Pointer_Size==8 ? MTYPE_I8 : MTYPE_I4, MTYPE_V); 01258 // wn = WN_Create_Intrinsic(op,INTRN_SUM,3,args); 01259 wn = WN_Create_Intrinsic(op,INTRN_COUNT,3,args); 01260 # if 0 01261 wn = F90_Wrap_ARREXP(wn); 01262 # endif 01263 cwh_stk_push(wn,WN_item); 01264 return; 01265 } 01266 01267 /*=============================================== 01268 * 01269 * fei_malloc, fei_alloc 01270 * 01271 * Space allocation. fei_malloc is the malloc 01272 * intrinsic(ie: heap). fei_alloc is used by 01273 * automatic arrays & local temps (ie: stack). 01274 * The amount to allocate is TOS. Create the 01275 * intrinsic, and push on the stack, for 01276 * fei_store to put away. 01277 * 01278 *=============================================== 01279 */ 01280 void 01281 fei_malloc (void) 01282 { 01283 WN * k[1]; 01284 WN * sz = NULL ; 01285 WN * call; 01286 BOOL v = TRUE; 01287 WN * wn ; 01288 INTRINSIC intr; 01289 char preg_name[32]; 01290 01291 /* Build the intrinsic_call node */ 01292 k[0] = cwh_expr_operand(NULL); 01293 intr = (Pointer_Size == 4) ? INTRN_U4I4MALLOC : INTRN_U8I8MALLOC; 01294 01295 call = cwh_intrin_call(intr, 1, k, &sz, &v, Pointer_Mtype); 01296 WN_Set_Call_Does_Mem_Alloc(call); 01297 01298 /* Get the return value */ 01299 wn = cwh_stmt_return_scalar(NULL, NULL, Be_Type_Tbl(Pointer_Mtype), FALSE); 01300 cwh_stk_push(wn,WN_item); 01301 sprintf(preg_name,"malloc@line_%d",USRCPOS_linenum(current_srcpos)); 01302 wn = cwh_intrin_get_return_value(Pointer_Mtype,preg_name); 01303 01304 01305 cwh_stk_push(wn,WN_item); 01306 } 01307 01308 void 01309 fei_alloc (void) 01310 { 01311 WN * k[1]; 01312 WN * wn ; 01313 01314 k[0] = cwh_expr_operand(NULL); 01315 if (Heap_Allocation_Threshold == -1) { 01316 wn = cwh_intrin_build(k,INTRN_F90_STACKTEMPALLOC,Pointer_Mtype,1); 01317 } else if (Heap_Allocation_Threshold == 0) { 01318 wn = cwh_intrin_build(k,INTRN_F90_HEAPTEMPALLOC,Pointer_Mtype,1); 01319 } else { 01320 wn = cwh_intrin_build(k,INTRN_F90_DYNAMICTEMPALLOC,Pointer_Mtype,1); 01321 } 01322 01323 cwh_stk_push(wn,WN_item); 01324 } 01325 01326 /*=============================================== 01327 * 01328 * fei_free, fei_mfree 01329 * 01330 * Return temp space,stack or heap. TOS has pointer. 01331 * An intrinsic call is tacked to the current block. 01332 * 01333 *=============================================== 01334 */ 01335 void 01336 fei_mfree (void) 01337 { 01338 WN * k[1]; 01339 WN * sz = NULL ; 01340 WN * call; 01341 BOOL val = TRUE; 01342 INTRINSIC intr; 01343 01344 intr = (Pointer_Size == 4) ? INTRN_U4FREE : INTRN_U8FREE; 01345 01346 k[0] = cwh_expr_operand(NULL); 01347 call = cwh_intrin_call(intr,1,k,&sz,&val,MTYPE_V); 01348 WN_Set_Call_Does_Mem_Free(call); 01349 } 01350 01351 void 01352 fei_free (void) 01353 { 01354 WN * k[1]; 01355 WN * sz = NULL ; 01356 BOOL val = TRUE; 01357 01358 k[0] = cwh_expr_operand(NULL); 01359 if (Heap_Allocation_Threshold == -1) { 01360 cwh_intrin_call(INTRN_F90_STACKTEMPFREE,1,k,&sz,&val,Pointer_Mtype); 01361 } else if (Heap_Allocation_Threshold == 0) { 01362 cwh_intrin_call(INTRN_F90_HEAPTEMPFREE,1,k,&sz,&val,Pointer_Mtype); 01363 } else { 01364 cwh_intrin_call(INTRN_F90_DYNAMICTEMPFREE,1,k,&sz,&val,Pointer_Mtype); 01365 } 01366 01367 } 01368 01369 /*=============================================== 01370 * 01371 * fei_ranf,fei_ranget,fei_ranset 01372 * 01373 * The next threee implement the random number 01374 * intrinsic subroutines RANDOM_NUMBER and RANDOM_SEED 01375 * 01376 * Ranf returns the next random number. 01377 * 01378 *=============================================== 01379 */ 01380 void 01381 fei_ranf(TYPE type) { 01382 WN *wn; 01383 TYPE_ID t; 01384 01385 t = TY_mtype(cast_to_TY(t_TY(type))); 01386 if (t == MTYPE_F4) { 01387 wn = WN_Create_Intrinsic(OPC_F4INTRINSIC_OP,INTRN_F4I4RAN,0,NULL); 01388 } else { 01389 wn = WN_Create_Intrinsic(OPC_F8INTRINSIC_OP,INTRN_F8I4RAN,0,NULL); 01390 } 01391 cwh_stk_push(wn,WN_item); 01392 } 01393 01394 /*=============================================== 01395 * 01396 * fei_ranget 01397 * 01398 * Do a GET operation for RANDOM SEED. ie: 01399 * return the current value of the seed. TOS has 01400 * the destination address. Create an 01401 * intrinsic call and push a NULL for fei_store. 01402 * 01403 *=============================================== 01404 */ 01405 void 01406 fei_ranget (TYPE type) { 01407 WN *addr; 01408 WN *call; 01409 INT64 flags = 0; 01410 01411 if (!ranget_st) { 01412 ranget_st = cwh_intrin_make_intrinsic_symbol("_RANGET",MTYPE_V); 01413 } 01414 01415 addr = cwh_expr_address(f_T_PASSED); 01416 cwh_stk_push(ranget_st,ST_item); 01417 cwh_stk_push(addr,ADDR_item); 01418 call = cwh_stmt_call_helper(1,Be_Type_Tbl(MTYPE_V),0,flags); 01419 01420 cwh_stk_push(NULL,WN_item); 01421 } 01422 01423 /*=============================================== 01424 * 01425 * fei_ranset 01426 * 01427 * Do a PUT operation for RANDOM SEED. ie: 01428 * establish a seed value. TOS has the seed 01429 * address. Create an intrinsic call and push 01430 * a NULL for fei_store. 01431 * 01432 *=============================================== 01433 */ 01434 void 01435 fei_ranset (TYPE type) { 01436 WN *call; 01437 WN *wn; 01438 INT64 flags = 0; 01439 01440 if (!ranset_st) { 01441 ranset_st = cwh_intrin_make_intrinsic_symbol("_RANSET",MTYPE_V); 01442 } 01443 01444 wn = cwh_expr_address(f_T_PASSED); 01445 cwh_stk_push(ranset_st,ST_item); 01446 cwh_stk_push(wn,ADDR_item); 01447 call = cwh_stmt_call_helper(1,Be_Type_Tbl(MTYPE_V),0,flags); 01448 01449 cwh_stk_push(NULL,WN_item); 01450 } 01451 01452 01453 void 01454 fei_rtc (TYPE type) { 01455 WN *call; 01456 WN *wn; 01457 INT64 flags = 0; 01458 01459 if (!rtc_st) { 01460 rtc_st = cwh_intrin_make_intrinsic_symbol("_IRTC_",MTYPE_I8); 01461 } 01462 01463 cwh_stk_push(rtc_st,ST_item); 01464 call = cwh_stmt_call_helper(0,Be_Type_Tbl(MTYPE_I8),0,flags); 01465 wn = cwh_intrin_get_return_value(MTYPE_I8,"@f90rtc"); 01466 wn = cwh_convert_to_ty(wn,TY_mtype(cast_to_TY(t_TY(type)))); 01467 cwh_stk_push(wn,WN_item); 01468 } 01469 01470 void 01471 fei_unit(void) 01472 { 01473 WN *call; 01474 WN *addr; 01475 WN *wn; 01476 INT64 flags = 0; 01477 01478 if (!unit_st) { 01479 unit_st = cwh_intrin_make_intrinsic_symbol("_UNIT_",MTYPE_F4); 01480 } 01481 01482 addr = cwh_expr_address(f_T_PASSED); 01483 cwh_stk_push(unit_st,ST_item); 01484 cwh_stk_push(addr,ADDR_item); 01485 call = cwh_stmt_call_helper(1,Be_Type_Tbl(MTYPE_F4),0,flags); 01486 01487 wn = cwh_intrin_get_return_value (MTYPE_F4,"@f90unit"); 01488 cwh_stk_push(wn,WN_item); 01489 01490 } 01491 01492 01493 void 01494 fei_length(void) 01495 { 01496 WN *call; 01497 WN *addr; 01498 WN *wn; 01499 INT64 flags = 0; 01500 01501 if (!length_st) { 01502 length_st = cwh_intrin_make_intrinsic_symbol("_LENGTH_",MTYPE_I4); 01503 } 01504 01505 addr = cwh_expr_address(f_T_PASSED); 01506 cwh_stk_push(length_st,ST_item); 01507 cwh_stk_push(addr,ADDR_item); 01508 call = cwh_stmt_call_helper(1,Be_Type_Tbl(MTYPE_I4),0,flags); 01509 01510 wn = cwh_intrin_get_return_value (MTYPE_I4,"@f90length"); 01511 cwh_stk_push(wn,WN_item); 01512 01513 } 01514 01515 01516 01517 void 01518 fei_present(void) 01519 { 01520 WN *wn; 01521 WN *arg; 01522 TY_IDX ty; 01523 01524 arg = cwh_expr_address(f_NONE); 01525 wn = WN_CreateExp2(OPCODE_make_op(OPR_NE,MTYPE_I4,Pointer_Mtype), 01526 arg, 01527 WN_Intconst(Pointer_Mtype,0)); 01528 cwh_stk_push_typed(wn,WN_item,logical4_ty); 01529 } 01530 01531 01532 01533 /*================================================================ 01534 * 01535 * fei_ibits: implement the IBITS intrinsic 01536 * 01537 * 01538 * IBITS(X,POS,LEN) = X >> POS && MASK 01539 * where mask is (1 << LEN) - 1. For 64 bit types, we add 01540 * a little check to ((LEN != 64) << LEN) - 1. That way, if LEN =64, 01541 * we get a mask with all 1's 01542 * 01543 *================================================================ 01544 */ 01545 01546 void 01547 fei_ibits(TYPE type) 01548 { 01549 WN *x, *pos, *len; 01550 WN *mask; 01551 TYPE_ID ty,rty; 01552 WN *ae=NULL; 01553 01554 len = cwh_expr_operand(&ae); 01555 pos = cwh_expr_operand(&ae); 01556 x = cwh_expr_operand(&ae); 01557 01558 rty = TY_mtype(cast_to_TY(t_TY(type))); 01559 ty = Mtype_comparison(rty); 01560 01561 x = WN_Lshr(ty,x,pos); 01562 01563 mask = cwh_generate_bitmask(len,ty); 01564 x = cwh_expr_bincalc(OPR_BAND,x,mask); 01565 x = cwh_wrap_cvtl(x,rty); 01566 01567 x = cwh_expr_restore_arrayexp(x,ae); 01568 cwh_stk_push(x,WN_item); 01569 } 01570 01571 /*================================================================ 01572 * 01573 * fei_mvbits: implement the MVBITS intrinsic 01574 * 01575 *================================================================ 01576 */ 01577 01578 void 01579 fei_mvbits(TYPE type) 01580 { 01581 WN *from,*frompos,*len,*to,*topos; 01582 WN *t1,*mask,*r; 01583 WN *ae=NULL; 01584 01585 TYPE_ID ty,rty; 01586 01587 topos = cwh_expr_operand(&ae); 01588 to = cwh_expr_operand(&ae); 01589 len = cwh_expr_operand(&ae); 01590 frompos = cwh_expr_operand(&ae); 01591 from = cwh_expr_operand(&ae); 01592 01593 rty = TY_mtype(cast_to_TY(t_TY(type))); 01594 ty = Mtype_comparison(rty); 01595 01596 from = WN_Lshr(ty,from,frompos); 01597 mask = cwh_generate_bitmask(len,ty); 01598 t1 = cwh_expr_bincalc(OPR_BAND,from,WN_COPY_Tree(mask)); 01599 t1 = cwh_expr_bincalc(OPR_SHL,t1,WN_COPY_Tree(topos)); 01600 01601 mask = WN_Shl(ty,mask,topos); 01602 mask = WN_CreateExp1(OPCODE_make_op(OPR_BNOT,ty,MTYPE_V),mask); 01603 01604 r = cwh_expr_bincalc(OPR_BAND,to,mask); 01605 r = cwh_expr_bincalc(OPR_BIOR,r,t1); 01606 r = cwh_wrap_cvtl(r,rty); 01607 01608 r = cwh_expr_restore_arrayexp(r,ae); 01609 cwh_stk_push(r,WN_item); 01610 fei_store(type); 01611 } 01612 01613 /*================================================================ 01614 * 01615 * cwh_char_intrin 01616 * 01617 * Utility for character intrinsic ops - used by scan/verify etc. 01618 * Create op and push the result. 01619 * 01620 * intr - intrinsic to call 01621 * numargs - number of arguments 01622 * 01623 * automatically detects string arguments 01624 *================================================================ 01625 */ 01626 static void 01627 cwh_char_intrin(INTRINSIC intr, INT numargs) 01628 { 01629 WN * args[5]; 01630 INT arg_count; 01631 INT i; 01632 WN *charlen; 01633 WN *charlen1; 01634 WN *wn; 01635 OPCODE op; 01636 01637 arg_count = 5; 01638 for (i = 0; i < numargs; i++) { 01639 if (cwh_stk_get_class() == STR_item) { 01640 cwh_stk_pop_STR(); 01641 charlen = cwh_expr_operand(NULL); 01642 charlen1 = WN_COPY_Tree(charlen); 01643 args[--arg_count] = cwh_intrin_wrap_value_parm(charlen); 01644 args[--arg_count] = cwh_expr_address(f_NONE); 01645 args[arg_count] = cwh_intrin_wrap_char_parm(args[arg_count],charlen1); 01646 } else { 01647 args[--arg_count] = cwh_intrin_wrap_value_parm(cwh_expr_operand(NULL)); 01648 } 01649 } 01650 01651 wn = WN_Create_Intrinsic(OPC_I4INTRINSIC_OP,intr,5-arg_count,&args[arg_count]); 01652 cwh_stk_push(wn,WN_item); 01653 } 01654 01655 01656 #define do_char_intrin(name,intr,args) void name(TYPE type) {cwh_char_intrin(intr,args);} 01657 #define do_char_intrin_nt(name,intr,args) void name(void) {cwh_char_intrin(intr,args);} 01658 01659 do_char_intrin(fei_scan,INTRN_SCAN,3) 01660 do_char_intrin(fei_verify,INTRN_VERIFY,3) 01661 do_char_intrin_nt(fei_index,INTRN_F90INDEX,3) 01662 do_char_intrin_nt(fei_len_trim,INTRN_LENTRIM,1) 01663 do_char_intrin_nt(fei_len,INTRN_I4CLEN,1) 01664 01665 01666 /*================================================================ 01667 * 01668 * fei_adjust{l,r} 01669 * 01670 * Intrinsics ADJUSTL/R - move a string. Turned into calls 01671 * which assign into the result (temp) below the argument 01672 * at TOS. Push NULLS so fei_store ignores result. 01673 * 01674 *================================================================ 01675 */ 01676 void 01677 fei_adjustl (TYPE type) 01678 { 01679 cwh_stmt_character_icall(INTRN_ADJUSTL); 01680 cwh_stk_push(NULL,WN_item); 01681 cwh_stk_push(NULL,WN_item); 01682 } 01683 01684 void 01685 fei_adjustr (TYPE type) 01686 { 01687 cwh_stmt_character_icall(INTRN_ADJUSTR); 01688 cwh_stk_push(NULL,WN_item); 01689 cwh_stk_push(NULL,WN_item); 01690 } 01691 01692 void 01693 fei_ieee_round(TYPE type) 01694 { 01695 fei_cvtop(type); 01696 } 01697 01698 01699 void 01700 fei_ieee_trunc(TYPE type) 01701 { 01702 TY_IDX ty; 01703 WN *ae=NULL; 01704 WN *r; 01705 TYPE_ID bt; 01706 INTRINSIC intr; 01707 01708 ty = cast_to_TY(t_TY(type)); 01709 bt = TY_mtype(ty); 01710 01711 /* Convert to REAL(16) then build the appropriate intrinsic */ 01712 r = cwh_expr_operand(&ae); 01713 r = cwh_convert_to_ty(r,MTYPE_FQ); 01714 intr = GET_ITAB_IOP(i_ieee_int,bt); 01715 r = cwh_intrin_build(&r, intr, bt, 1); 01716 r = cwh_wrap_cvtl(r,bt); 01717 r = cwh_expr_restore_arrayexp(r,ae); 01718 cwh_stk_push_typed(r,WN_item,ty); 01719 } 01720 01721 /* Build POPCNT and LEADZ */ 01722 /* type is the type of the intrinsic, arg is the type of the argument */ 01723 static void 01724 cwh_intrin_popcnt_leadz_helper(INTRINSIC i1, INTRINSIC i2, INTRINSIC i4, INTRINSIC i8, 01725 TYPE rtype, TYPE arg) 01726 { 01727 WN *wn; 01728 WN *r; 01729 TYPE_ID t,ti,rt; 01730 INTRINSIC intr; 01731 WN *ae=NULL; 01732 01733 t = TY_mtype(t_TY(arg)); 01734 rt = TY_mtype(t_TY(rtype)); 01735 01736 wn = cwh_expr_operand(&ae); 01737 01738 /* For non integral types, we need to create a cast */ 01739 if (!MTYPE_is_integral(t)) { 01740 if (MTYPE_size_reg(t) == 32) { 01741 ti = MTYPE_U4; 01742 } else { 01743 ti = MTYPE_U8; 01744 } 01745 wn = WN_Tas(ti,Be_Type_Tbl(t),wn); 01746 } else { 01747 ti = t; 01748 } 01749 switch (ti) { 01750 case MTYPE_U1: case MTYPE_I1: 01751 intr = i1; 01752 /* need to mask off low bits and convert to U4 */ 01753 wn = cwh_expr_bincalc(OPR_BAND,WN_Intconst(MTYPE_U4,255),wn); 01754 break; 01755 case MTYPE_U2: case MTYPE_I2: 01756 intr = i2; 01757 /* need to mask off low bits and convert to U4 */ 01758 wn = cwh_expr_bincalc(OPR_BAND,WN_Intconst(MTYPE_U4,65535),wn); 01759 break; 01760 case MTYPE_U4: case MTYPE_I4: intr = i4; break; 01761 case MTYPE_U8: case MTYPE_I8: intr = i8; break; 01762 default: DevAssert(0,("Unknown type")); 01763 } 01764 01765 wn = cwh_intrin_wrap_value_parm(wn); 01766 r = WN_Create_Intrinsic(OPC_I4INTRINSIC_OP,intr,1,&wn); 01767 r = cwh_convert_to_ty(r,rt); 01768 r = cwh_expr_restore_arrayexp(r,ae); 01769 cwh_stk_push(r,WN_item); 01770 } 01771 01772 01773 void 01774 fei_popcnt (TYPE type, TYPE arg) 01775 { 01776 cwh_intrin_popcnt_leadz_helper(INTRN_I1POPCNT,INTRN_I2POPCNT, 01777 INTRN_I4POPCNT,INTRN_I8POPCNT,type,arg); 01778 } 01779 01780 01781 void 01782 fei_leadz (TYPE type, TYPE arg) 01783 { 01784 cwh_intrin_popcnt_leadz_helper(INTRN_I1LEADZ,INTRN_I2LEADZ, 01785 INTRN_I4LEADZ,INTRN_I8LEADZ,type,arg); 01786 } 01787 01788 void 01789 fei_poppar (TYPE type, TYPE arg) 01790 { 01791 WN *wn; 01792 WN *ae=NULL; 01793 fei_popcnt(type, arg); 01794 wn = cwh_expr_bincalc(OPR_BAND,cwh_expr_operand(&ae),WN_Intconst(MTYPE_I4,1)); 01795 wn = cwh_expr_restore_arrayexp(wn,ae); 01796 cwh_stk_push(wn,WN_item); 01797 } 01798 01799 01800 /*================================================================ 01801 * Utility routine for several of the IEEE intrinsics which don't have 01802 * REAL(4) implementations 01803 * 01804 * intr - intrinsic to use 01805 * numargs - number of arguments 01806 * t - type of the returned intrinsic 01807 * cvtf4 - if TRUE, F4 intrinsics are converted to F8 intrinsics 01808 * ae - ARRAYEXP node to possibly put on top 01809 * 01810 *================================================================ 01811 */ 01812 01813 static void cwh_funny_fp_intrinsic(INTRINSIC intr, INT numargs, WN **args, TY_IDX ty, 01814 BOOL cvtf4, WN *ae) 01815 { 01816 INT i; 01817 WN *wn; 01818 OPCODE opc; 01819 TYPE_ID t; 01820 01821 t = TY_mtype(ty); 01822 01823 /* Convert all REAL(4) arguments to type double */ 01824 for (i=0; i < numargs; i++) { 01825 if (WN_rtype(args[i]) == MTYPE_F4 && cvtf4) { 01826 args[i] = cwh_convert_to_ty(args[i],MTYPE_F8); 01827 } 01828 args[i] = cwh_intrin_wrap_value_parm(args[i]); 01829 } 01830 01831 if (t == MTYPE_F4 && cvtf4) { 01832 opc = OPC_F8INTRINSIC_OP; 01833 } else { 01834 opc = cwh_make_typed_opcode(OPR_INTRINSIC_OP, t, MTYPE_V); 01835 } 01836 01837 wn = WN_Create_Intrinsic(opc,intr,numargs,args); 01838 01839 /* Convert back to REAL(4) if necessary */ 01840 if (t == MTYPE_F4 && cvtf4) { 01841 wn = cwh_convert_to_ty(wn,MTYPE_F4); 01842 } 01843 wn = cwh_expr_restore_arrayexp(wn,ae); 01844 cwh_stk_push_typed(wn,WN_item,ty); 01845 } 01846 01847 01848 #define SELECT_INTRINSIC(t,f) ((t==MTYPE_F4) ? INTRN_F4##f : \ 01849 ((t==MTYPE_F8) ? INTRN_F8##f : INTRN_FQ##f)) 01850 01851 void 01852 fei_scalb(TYPE type) 01853 { 01854 WN *args[2]; 01855 INTRINSIC intr; 01856 TYPE_ID t; 01857 WN *ae=NULL; 01858 01859 args[1] = cwh_get_typed_operand(MTYPE_I4,&ae); 01860 args[0] = cwh_expr_operand(&ae); 01861 t = WN_rtype(args[0]); 01862 intr = SELECT_INTRINSIC(t,SCALB); 01863 cwh_funny_fp_intrinsic(intr,2,args,Be_Type_Tbl(t),TRUE,ae); 01864 } 01865 01866 void 01867 fei_remainder(TYPE type) 01868 { 01869 WN *args[2]; 01870 INTRINSIC intr; 01871 TYPE_ID t; 01872 WN *ae=NULL; 01873 01874 args[1] = cwh_expr_operand(&ae); 01875 args[0] = cwh_expr_operand(&ae); 01876 t = cwh_get_highest_type(args[0],args[1]); 01877 args[0] = cwh_convert_to_ty(args[0],t); 01878 args[1] = cwh_convert_to_ty(args[1],t); 01879 01880 intr = SELECT_INTRINSIC(t,IEEE_REMAINDER); 01881 cwh_funny_fp_intrinsic(intr,2,args,Be_Type_Tbl(t),TRUE,ae); 01882 } 01883 01884 void 01885 fei_logb(TYPE type) 01886 { 01887 WN *args[1]; 01888 INTRINSIC intr; 01889 TYPE_ID t,rt,ot; 01890 WN *wn; 01891 WN *ae=NULL; 01892 WN *argeq0; 01893 INT64 mhuge; 01894 01895 rt = TY_mtype(cast_to_TY(t_TY(type))); 01896 args[0] = cwh_expr_operand(&ae); 01897 t = WN_rtype(args[0]); 01898 argeq0 = WN_EQ(t,WN_COPY_Tree(args[0]),WN_Zerocon(t)); 01899 intr = SELECT_INTRINSIC(t,LOGB); 01900 cwh_funny_fp_intrinsic(intr,1,args,Be_Type_Tbl(t),TRUE,NULL); 01901 if (MTYPE_is_integral(rt)) { 01902 ot = MTYPE_I4; 01903 switch (rt) { 01904 case MTYPE_I1: 01905 mhuge = 127LL; 01906 break; 01907 case MTYPE_I2: 01908 mhuge = 32767LL; 01909 break; 01910 case MTYPE_I4: 01911 mhuge = 2147483647LL; 01912 break; 01913 case MTYPE_I8: 01914 default: 01915 mhuge = 9223372036854775807LL; 01916 ot = MTYPE_I8; 01917 break; 01918 } 01919 /* Need to limit the range to +HUGE(0), and set 0 to -HUGE(0) 01920 * because floating-point conversion doesn't get things quite right 01921 */ 01922 wn = cwh_get_typed_operand(ot,NULL); 01923 if (rt == MTYPE_I1 || rt == MTYPE_I2) { 01924 wn = WN_CreateExp2(OPC_I4MIN,wn,WN_Intconst(MTYPE_I4,mhuge)); 01925 } 01926 wn = WN_Select(ot,argeq0,WN_Intconst(ot,-mhuge),wn); 01927 wn = cwh_wrap_cvtl(wn,rt); 01928 } else { 01929 wn = cwh_get_typed_operand(rt,NULL); 01930 } 01931 wn = cwh_expr_restore_arrayexp(wn,ae); 01932 cwh_stk_push_typed(wn,WN_item,Be_Type_Tbl(rt)); 01933 } 01934 01935 void 01936 fei_isfinite(TYPE type) 01937 { 01938 WN *args[1]; 01939 INTRINSIC intr; 01940 TYPE_ID t; 01941 WN *ae=NULL; 01942 01943 args[0] = cwh_expr_operand(&ae); 01944 t = WN_rtype(args[0]); 01945 intr = SELECT_INTRINSIC(t,FINITE); 01946 cwh_funny_fp_intrinsic(intr,1,args,logical4_ty,TRUE,ae); 01947 } 01948 01949 void 01950 fei_isnan(TYPE type) 01951 { 01952 WN *args[1]; 01953 INTRINSIC intr; 01954 TYPE_ID t; 01955 WN *ae=NULL; 01956 01957 args[0] = cwh_expr_operand(&ae); 01958 t = WN_rtype(args[0]); 01959 intr = SELECT_INTRINSIC(t,ISNAN); 01960 cwh_funny_fp_intrinsic(intr,1,args,logical4_ty,FALSE,ae); 01961 } 01962 01963 void 01964 fei_isunordered(TYPE type) 01965 { 01966 WN *args[2]; 01967 INTRINSIC intr; 01968 TYPE_ID t; 01969 WN *ae=NULL; 01970 01971 args[1] = cwh_expr_operand(&ae); 01972 args[0] = cwh_expr_operand(&ae); 01973 t = WN_rtype(args[0]); 01974 intr = SELECT_INTRINSIC(t,UNORDERED); 01975 cwh_funny_fp_intrinsic(intr,2,args,logical4_ty,TRUE,ae); 01976 } 01977 01978 void 01979 fei_fpclass(TYPE type) 01980 { 01981 WN *args[1]; 01982 INTRINSIC intr; 01983 TYPE_ID t; 01984 WN *ae=NULL; 01985 01986 args[0] = cwh_expr_operand(&ae); 01987 t = WN_rtype(args[0]); 01988 intr = SELECT_INTRINSIC(t,FPCLASS); 01989 cwh_funny_fp_intrinsic(intr,1,args,Be_Type_Tbl(MTYPE_I4),FALSE,ae); 01990 } 01991 01992 #define UNIMPLEMENTED(fname) void fname() {printf("%3d %s\n",__LINE__,# fname);} 01993 01994 01995 01996 /* Helper function for IEEE intrinsics */ 01997 static void 01998 cwh_intrin_ieee_intrin_call_helper(INTRINSIC intrin, TYPE_ID type, INT nargs, 01999 BOOL issue_warning, char * iname) 02000 { 02001 BOOL v[2]; 02002 WN *args[2]; 02003 WN *sz[2]; 02004 INT i; 02005 WN *wn; 02006 02007 if (issue_warning && (Opt_Level != 0)) { 02008 ErrMsg(EC_IEEE_Intrinsic_Warning,iname); 02009 } 02010 02011 sz[0] = NULL; 02012 sz[1] = NULL; 02013 v[0] = TRUE; 02014 v[1] = TRUE; 02015 02016 for (i=nargs-1 ; i >= 0; i--) { 02017 args[i] = cwh_expr_operand(NULL); 02018 } 02019 02020 cwh_intrin_call(intrin, nargs, args, sz, v, type); 02021 if (type != MTYPE_V ) { 02022 wn = cwh_stmt_return_scalar(NULL, NULL, Be_Type_Tbl(type), FALSE); 02023 cwh_stk_push(wn,WN_item); 02024 } 02025 } 02026 02027 #define IEEE_INTRINCALL(name,intrin,rty,nargs,warn_msg) \ 02028 extern void name (void) {cwh_intrin_ieee_intrin_call_helper(INTRN_##intrin,rty,nargs,warn_msg,#intrin); } 02029 02030 IEEE_INTRINCALL(fei_set_all_estat,SET_IEEE_EXCEPTIONS,MTYPE_V,1,TRUE); 02031 IEEE_INTRINCALL(fei_get_interupt,GET_IEEE_INTERRUPTS,MTYPE_I4,0,FALSE); 02032 IEEE_INTRINCALL(fei_get_all_estat,GET_IEEE_EXCEPTIONS,MTYPE_I4,0,TRUE); 02033 IEEE_INTRINCALL(fei_readsr,GET_IEEE_STATUS,MTYPE_I4,1,TRUE); 02034 IEEE_INTRINCALL(fei_get_rmode,GET_IEEE_ROUNDING_MODE,MTYPE_I4,0,FALSE); 02035 IEEE_INTRINCALL(fei_set_rmode,SET_IEEE_ROUNDING_MODE,MTYPE_V,1,TRUE); 02036 IEEE_INTRINCALL(fei_set_ieee_stat,SET_IEEE_STATUS,MTYPE_V,1,TRUE); 02037 IEEE_INTRINCALL(fei_set_interupt,SET_IEEE_INTERRUPTS,MTYPE_V,1,TRUE); 02038 IEEE_INTRINCALL(fei_set_estat,SET_IEEE_EXCEPTION,MTYPE_V,2,TRUE); 02039 IEEE_INTRINCALL(fei_dsbl_interupt,DISABLE_IEEE_INTERRUPT,MTYPE_V,1,TRUE); 02040 IEEE_INTRINCALL(fei_enbl_interupt,ENABLE_IEEE_INTERRUPT,MTYPE_V,1,TRUE); 02041 02042 02043 02044 /* Helper function for IEEE intrinsics */ 02045 static void 02046 cwh_intrin_ieee_intrin_helper(INTRINSIC intrin,BOOL issue_warning,char *iname) 02047 { 02048 WN *args; 02049 WN *sz; 02050 BOOL v; 02051 02052 WN *wn; 02053 TY_IDX ty; 02054 WN *oldblock; 02055 02056 if (issue_warning && (Opt_Level != 0)) { 02057 ErrMsg(EC_IEEE_Intrinsic_Warning,iname); 02058 } 02059 02060 oldblock = cwh_block_new_and_current(); 02061 02062 args = cwh_expr_operand(NULL); 02063 sz = NULL; 02064 v = TRUE; 02065 cwh_intrin_call(intrin, 1, &args, &sz, &v, MTYPE_I4); 02066 02067 /* Get the return value */ 02068 wn = cwh_stmt_return_scalar(NULL, NULL, logical4_ty, FALSE); 02069 cwh_stk_push(wn,WN_item); 02070 wn = cwh_intrin_get_return_value(MTYPE_I4,"f90ieeelogval"); 02071 02072 /* Get the call block */ 02073 oldblock = cwh_block_exchange_current(oldblock); 02074 02075 /* Build the COMMA node */ 02076 wn = WN_CreateComma(OPC_I4COMMA,oldblock,wn); 02077 cwh_stk_push_typed(wn,WN_item,logical4_ty); 02078 } 02079 02080 02081 void 02082 fei_test_interupt(void) 02083 { 02084 cwh_intrin_ieee_intrin_helper(INTRN_TEST_IEEE_INTERRUPT,FALSE,NULL); 02085 } 02086 02087 void 02088 fei_test_estat(void) 02089 { 02090 cwh_intrin_ieee_intrin_helper(INTRN_TEST_IEEE_EXCEPTION,TRUE,"TEST_IEEE_EXCEPTION"); 02091 } 02092 02093 02094 /* 02095 * OMP Intrinsics 02096 */ 02097 void fei_omp_set_lock(void) 02098 { 02099 WN *args; 02100 WN *wn; 02101 INT64 flags = 0; 02102 02103 if (!omp_set_lock_st) { 02104 omp_set_lock_st = cwh_intrin_make_intrinsic_symbol("omp_set_lock_",MTYPE_V); 02105 } 02106 args = cwh_expr_address(f_T_PASSED); 02107 cwh_stk_push(omp_set_lock_st,ST_item); 02108 cwh_stk_push(args,WN_item); 02109 cwh_stmt_call_helper(1,Be_Type_Tbl(MTYPE_V),0,flags); 02110 02111 /* Insert the backward barrier */ 02112 wn = WN_CreateBarrier( FALSE, 0 ); 02113 cwh_block_append(wn); 02114 } 02115 02116 void fei_omp_unset_lock(void) 02117 { 02118 WN *args; 02119 WN *wn; 02120 INT64 flags = 0; 02121 02122 if (!omp_unset_lock_st) { 02123 omp_unset_lock_st = cwh_intrin_make_intrinsic_symbol("omp_unset_lock_",MTYPE_V); 02124 } 02125 /* Insert the forward barrier */ 02126 wn = WN_CreateBarrier( TRUE, 0 ); 02127 cwh_block_append(wn); 02128 02129 args = cwh_expr_address(f_T_PASSED); 02130 cwh_stk_push(omp_unset_lock_st,ST_item); 02131 cwh_stk_push(args,WN_item); 02132 cwh_stmt_call_helper(1,Be_Type_Tbl(MTYPE_V),0,flags); 02133 02134 } 02135 02136 02137 void fei_omp_test_lock(void) 02138 { 02139 WN *args; 02140 WN *wn; 02141 WN *rval; 02142 INT64 flags = 0; 02143 02144 if (!omp_test_lock_st) { 02145 omp_test_lock_st = cwh_intrin_make_intrinsic_symbol("omp_test_lock_",MTYPE_I4); 02146 } 02147 02148 args = cwh_expr_address(f_T_PASSED); 02149 cwh_stk_push(omp_test_lock_st,ST_item); 02150 cwh_stk_push(args,WN_item); 02151 cwh_stmt_call_helper(1,Be_Type_Tbl(MTYPE_I4),0,flags); 02152 rval = cwh_intrin_get_return_value(MTYPE_I4,"@f90testlock"); 02153 02154 /* Insert the backward barrier */ 02155 wn = WN_CreateBarrier( FALSE, 0 ); 02156 cwh_block_append(wn); 02157 02158 /* Push the return value */ 02159 cwh_stk_push_typed(rval,WN_item,logical4_ty); 02160 } 02161 02162 02163 /*================================================================ 02164 * 02165 * Helper routine for synchronization intrinsics 02166 * 02167 * 02168 *================================================================ 02169 */ 02170 02171 static void 02172 cwh_intrin_sync_intrin(INTRINSIC i4intrin, INTRINSIC i8intrin, TYPE_ID rtype, INT num_args) 02173 { 02174 WN *args[3]; /* Max number of arguments */ 02175 BOOL v[3]; 02176 WN *sz[3]; 02177 INT i; 02178 ST *st; 02179 WN *wn; 02180 TYPE_ID atype; 02181 INTRINSIC intr; 02182 02183 /* Insert the FORWARD_BARRIER */ 02184 cwh_block_append(WN_CreateBarrier (TRUE, 0)); 02185 atype = rtype; 02186 02187 /* Get the arguments */ 02188 for (i=num_args-1; i >= 0; i--) { 02189 sz[i] = NULL; 02190 if (i != 0) { 02191 v[i] = TRUE; 02192 args[i] = cwh_expr_operand(NULL); 02193 } else { 02194 v[i] = FALSE; 02195 if (cwh_stk_get_class() == ST_item) { 02196 args[i] = cwh_expr_address(f_T_PASSED); 02197 } else { 02198 /* Need to store to a temp first */ 02199 wn = cwh_expr_operand(NULL); 02200 atype = WNRTY(wn); 02201 st = cwh_stab_temp_ST(Be_Type_Tbl(atype),"synctmp"); 02202 cwh_addr_store_ST(st,0,0,wn); 02203 args[i] = cwh_addr_address_ST(st,0); 02204 cwh_expr_set_flags(st,f_T_PASSED); 02205 } 02206 } 02207 } 02208 02209 /* Select the intrinsic type */ 02210 if (rtype == MTYPE_V && atype != MTYPE_V) { 02211 intr = (atype == MTYPE_I8 ? i8intrin : i4intrin); 02212 } else if (rtype == MTYPE_V && atype == MTYPE_V) { 02213 intr = i4intrin; 02214 } else { 02215 intr = (rtype == MTYPE_I8 ? i8intrin : i4intrin); 02216 } 02217 02218 /* Build the intrinsic_call node */ 02219 cwh_intrin_call(intr, num_args, args, sz, v, rtype); 02220 02221 if (rtype != MTYPE_V) { 02222 /* Get the return value */ 02223 wn = cwh_stmt_return_scalar(NULL, NULL, Be_Type_Tbl(rtype), FALSE); 02224 cwh_stk_push(wn,WN_item); 02225 wn = cwh_intrin_get_return_value(rtype,"syncpreg"); 02226 cwh_stk_push(wn,WN_item); 02227 } 02228 02229 /* Insert the backward barrier */ 02230 cwh_block_append(WN_CreateBarrier (FALSE, 0)); 02231 } 02232 02233 #define SYNC_INTRIN(name,iname,nargs) void name (TYPE type) {\ 02234 cwh_intrin_sync_intrin(INTRN_##iname##_I4,INTRN_##iname##_I8,TY_mtype(cast_to_TY(t_TY(type))),nargs);} 02235 02236 /* syncronization intrinsics */ 02237 SYNC_INTRIN(fei_fetch_and_add,FETCH_AND_ADD,2) 02238 SYNC_INTRIN(fei_fetch_and_and,FETCH_AND_AND,2) 02239 SYNC_INTRIN(fei_fetch_and_nand,FETCH_AND_NAND,2) 02240 SYNC_INTRIN(fei_fetch_and_or,FETCH_AND_OR,2) 02241 SYNC_INTRIN(fei_fetch_and_sub,FETCH_AND_SUB,2) 02242 SYNC_INTRIN(fei_fetch_and_xor,FETCH_AND_XOR,2) 02243 SYNC_INTRIN(fei_add_and_fetch,ADD_AND_FETCH,2) 02244 SYNC_INTRIN(fei_and_and_fetch,AND_AND_FETCH,2) 02245 SYNC_INTRIN(fei_nand_and_fetch,NAND_AND_FETCH,2) 02246 SYNC_INTRIN(fei_or_and_fetch,OR_AND_FETCH,2) 02247 SYNC_INTRIN(fei_sub_and_fetch,SUB_AND_FETCH,2) 02248 SYNC_INTRIN(fei_xor_and_fetch,XOR_AND_FETCH,2) 02249 SYNC_INTRIN(fei_compare_and_swap,COMPARE_AND_SWAP,3) 02250 SYNC_INTRIN(fei_lock_test_and_set,LOCK_TEST_AND_SET,2) 02251 02252 void 02253 fei_synchronize (void) 02254 { 02255 cwh_intrin_sync_intrin(INTRN_SYNCHRONIZE,INTRN_SYNCHRONIZE,MTYPE_V,0); 02256 } 02257 02258 void 02259 fei_lock_release(void) 02260 { 02261 cwh_intrin_sync_intrin(INTRN_LOCK_RELEASE_I4,INTRN_LOCK_RELEASE_I8,MTYPE_V,1); 02262 } 02263 02264 02265 /*=============================================== 02266 * 02267 * cwh_intrin_call 02268 * 02269 * Make an intrinsic call, given the intrinsic 02270 * and a list of arguments. The kids will be 02271 * wrapped with PARM nodes (side effect..). 02272 * 02273 * If a character address is a passed in, then 02274 * a SZ entry describing the substring size has 02275 * to be provided. The boolean flags say if 02276 * value or reference parms are required. 02277 * 02278 * appends the call to the current block, returns the call node 02279 * 02280 *=============================================== 02281 */ 02282 extern WN * 02283 cwh_intrin_call(INTRINSIC intr, INT16 numargs, WN ** k, WN**sz, BOOL *v, TYPE_ID bt ) 02284 { 02285 INT16 i ; 02286 OPCODE opc ; 02287 WN * wn ; 02288 02289 opc = cwh_make_typed_opcode(OPR_INTRINSIC_CALL, bt, MTYPE_V); 02290 02291 for (i = 0 ; i < numargs; i++) { 02292 if (v[i]) 02293 k[i] = cwh_intrin_wrap_value_parm(k[i]); 02294 else if (sz[i] != NULL) 02295 k[i] = cwh_intrin_wrap_char_parm(k[i],sz[i]); 02296 else 02297 k[i] = cwh_intrin_wrap_ref_parm(k[i], (TY_IDX) NULL); 02298 } 02299 02300 wn = WN_Create_Intrinsic(opc,intr,numargs,k); 02301 02302 WN_Set_Call_Default_Flags(wn); 02303 02304 if (intr!=INTRN_CONCATEXPR) 02305 cwh_block_append(wn); 02306 02307 return (wn); 02308 } 02309 02310 /*=============================================== 02311 * 02312 * cwh_intrin_op 02313 * 02314 * Make an intrinsic op, given the intrinsic 02315 * and a list of arguments. The kids will be 02316 * wrapped with PARM nodes (side effect..). 02317 * 02318 * If a character address is a passed in, then 02319 * a SZ entry describing the substring size has 02320 * to be provided. The boolean flags say if 02321 * value or reference parms are required. 02322 * 02323 *=============================================== 02324 */ 02325 02326 extern WN * 02327 cwh_intrin_op(INTRINSIC intr, INT16 numargs, WN ** k, WN**sz, BOOL *v, TYPE_ID bt ) 02328 { 02329 INT16 i ; 02330 OPCODE opc ; 02331 WN * wn ; 02332 02333 opc = cwh_make_typed_opcode(OPR_INTRINSIC_OP, bt, MTYPE_V); 02334 02335 for (i = 0 ; i < numargs; i++) { 02336 if (v[i]) 02337 k[i] = cwh_intrin_wrap_value_parm(k[i]); 02338 else if (sz[i] != NULL) 02339 k[i] = cwh_intrin_wrap_char_parm(k[i],sz[i]); 02340 else 02341 k[i] = cwh_intrin_wrap_ref_parm(k[i], (TY_IDX) NULL); 02342 } 02343 02344 wn = WN_Create_Intrinsic(opc,intr,numargs,k); 02345 02346 return(wn); 02347 } 02348 02349 /*=============================================== 02350 * 02351 * cwh_intrin_build 02352 * 02353 * Make an intrinsic op, given the intrinsic, 02354 * its result type and a list of arguments. The args 02355 * will be wrapped as value parms (side effect). 02356 * 02357 *=============================================== 02358 */ 02359 static WN * 02360 cwh_intrin_build(WN **k, INTRINSIC intr,TYPE_ID bt, INT numargs) 02361 { 02362 INT i; 02363 OPCODE opc; 02364 WN *wn ; 02365 02366 opc = cwh_make_typed_opcode(OPR_INTRINSIC_OP, bt, MTYPE_V); 02367 02368 for (i = 0 ; i < numargs; i++) 02369 k[i] = cwh_intrin_wrap_value_parm(k[i]); 02370 02371 wn = WN_Create_Intrinsic(opc,intr,numargs,k); 02372 02373 return wn ; 02374 } 02375 02376 02377 /*============================================= 02378 * 02379 * cwh_whirl_simplfier_control(BOOL onoff); 02380 * 02381 * We may need to turn the simplifier off at some point in the 02382 * processing of some expressions. For each call with FALSE, we increment the 02383 * number of times we've been called, and turn off the simplifier. 02384 * Each TRUE turns it back on again. 02385 * 02386 *============================================= 02387 */ 02388 extern void 02389 cwh_whirl_simplfier_control(BOOL onoff) 02390 { 02391 #if 0 /* do nothing for now */ 02392 static INT32 onoff_count=0; 02393 static BOOL simplifier_enabled; 02394 02395 printf("onoff count = %d\n",onoff_count); 02396 if (onoff) { 02397 /* Turn it back on */ 02398 if (onoff_count == 1) { 02399 (void) WN_Simplifier_Enable(save_wn_simplifier_enable); 02400 } 02401 if (onoff_count > 0) { 02402 onoff_count -= 1; 02403 } 02404 } else { 02405 /* Turn simplifier off */ 02406 (void) WN_Simplifier_Enable(save_wn_simplifier_enable); 02407 onoff_count += 1; 02408 } 02409 #endif 02410 }