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 #ifdef USE_PCH 00037 #include "common_com_pch.h" 00038 #endif /* USE_PCH */ 00039 #pragma hdrstop 00040 #include "defs.h" 00041 #include "wn.h" 00042 #include "wn_util.h" 00043 00044 #include "f90_utils.h" 00045 00046 00047 /* Returns TRUE if the intrinsic is one of the F90 transformational intrinsics 00048 */ 00049 00050 BOOL F90_Is_Transformational(INT32 intrinsic) 00051 { 00052 switch (intrinsic) { 00053 case INTRN_MATMUL: 00054 case INTRN_SPREAD: 00055 case INTRN_RESHAPE: 00056 case INTRN_TRANSPOSE: 00057 case INTRN_ALL: 00058 case INTRN_ANY: 00059 case INTRN_COUNT: 00060 case INTRN_PRODUCT: 00061 case INTRN_SUM: 00062 case INTRN_EOSHIFT: 00063 case INTRN_MAXVAL: 00064 case INTRN_MINVAL: 00065 case INTRN_MAXLOC: 00066 case INTRN_MINLOC: 00067 case INTRN_CSHIFT: 00068 case INTRN_DOT_PRODUCT: 00069 case INTRN_PACK: 00070 case INTRN_UNPACK: 00071 return(TRUE); 00072 default: 00073 return (FALSE); 00074 } 00075 } 00076 00077 /* Returns TRUE if the intrinsic is one of the F90 Character intrinsics 00078 */ 00079 BOOL F90_Is_Char_Intrinsic(INT32 intr) 00080 { 00081 switch(intr) { 00082 case INTRN_CASSIGNSTMT: 00083 case INTRN_CONCATEXPR: 00084 case INTRN_ADJUSTL: 00085 case INTRN_ADJUSTR: 00086 case INTRN_CEQEXPR: 00087 case INTRN_CNEEXPR: 00088 case INTRN_CGEEXPR: 00089 case INTRN_CGTEXPR: 00090 case INTRN_CLEEXPR: 00091 case INTRN_CLTEXPR: 00092 case INTRN_I4CLEN: 00093 case INTRN_I4CINDEX: 00094 case INTRN_CLGE: 00095 case INTRN_CLGT: 00096 case INTRN_CLLE: 00097 case INTRN_CLLT: 00098 case INTRN_LENTRIM: 00099 case INTRN_F90INDEX: 00100 case INTRN_SCAN: 00101 case INTRN_VERIFY: 00102 return (TRUE); 00103 default: 00104 return (FALSE); 00105 } 00106 } 00107 00108 00109 00110 /*================================================================ 00111 * Check to see if a node represents a DIM= 00112 * argument. Return 0 if no DIM= is present, otherwise 00113 * return the value of DIM 00114 *================================================================/ 00115 */ 00116 INT F90_Get_Dim(WN *dim_wn) 00117 { 00118 OPERATOR opr; 00119 opr = WN_operator(dim_wn); 00120 if (WN_opcode(dim_wn) == OPC_VPARM) { 00121 return (0); 00122 } else if (opr == OPR_PARM) { 00123 return (F90_Get_Dim(WN_kid0(dim_wn))); 00124 } else if (opr == OPR_INTCONST) { 00125 return (WN_const_val(dim_wn)); 00126 } else { 00127 return (0); 00128 } 00129 } 00130 00131 00132 00133 00134 00135 /*================================================================ 00136 * 00137 * Utility routine for sizing a tree 00138 * returns TRUE if the tree is not scalar, and ndim and sizes are 00139 * set to the number of dimensions and the sizes of each. sizes is a copy 00140 * of WHIRL in the tree, so it should be deleted to save space afterward. 00141 *================================================================ 00142 */ 00143 00144 BOOL F90_Size_Walk(WN *expr, INT *ndim, WN **sizes) 00145 { 00146 WN *temp; 00147 WN *temp_sizes[MAX_NDIM]; 00148 INT child_ndim; 00149 INT i,j,dim,numkids; 00150 BOOL sized; 00151 00152 *ndim = 0; 00153 sized = FALSE; 00154 00155 if (expr == NULL) 00156 return (TRUE); //fzhao try May 28 00157 00158 switch (WN_operator(expr)) { 00159 case OPR_COMMA: 00160 /* Size the things in the block */ 00161 temp = WN_first(WN_kid0(expr)); 00162 while (temp) { 00163 sized = F90_Size_Walk(temp,ndim,sizes); 00164 if (sized) return (TRUE); 00165 temp = WN_next(temp); 00166 } 00167 return (FALSE); 00168 00169 case OPR_RCOMMA: 00170 /* Size the things in the block */ 00171 temp = WN_first(WN_kid1(expr)); 00172 while (temp) { 00173 sized = F90_Size_Walk(temp,ndim,sizes); 00174 if (sized) return (TRUE); 00175 temp = WN_next(temp); 00176 } 00177 return (FALSE); 00178 00179 case OPR_ARRAYEXP: 00180 numkids = WN_kid_count(expr); 00181 if (numkids != 1) { 00182 *ndim = numkids-1; 00183 for (i = 1; i < numkids; i++) { 00184 sizes[i-1] = WN_COPY_Tree(WN_kid(expr,i)); 00185 } 00186 return (TRUE); 00187 } 00188 /* Just size the child */ 00189 break; 00190 00191 case OPR_ARRSECTION: 00192 numkids = (WN_kid_count(expr) - 1)/2; 00193 j = 0; 00194 for (i = 1; i <= numkids; i++) { 00195 if (F90_Size_Walk(WN_kid(expr,i+numkids),&child_ndim,temp_sizes)) { 00196 sizes[j] = temp_sizes[0]; 00197 j += 1; 00198 } 00199 } 00200 *ndim = j; 00201 return (j != 0); 00202 00203 case OPR_TRIPLET: 00204 case OPR_SRCTRIPLET: 00205 *ndim = 1; 00206 sizes[0] = WN_COPY_Tree(WN_kid2(expr)); 00207 return (TRUE); 00208 00209 case OPR_INTRINSIC_OP: 00210 switch (WN_intrinsic(expr)) { 00211 case INTRN_SPREAD: 00212 sized = F90_Size_Walk(WN_kid0(expr),&child_ndim,temp_sizes); 00213 if (!sized) { 00214 /* Scalar expression */ 00215 child_ndim = 0; 00216 } 00217 dim = child_ndim - F90_Get_Dim(WN_kid1(expr)) + 1; 00218 for (i=0,j=0; i <= child_ndim; i++) { 00219 if (i == dim) { 00220 sizes[i] = WN_COPY_Tree(WN_kid0(WN_kid2(expr))); 00221 } else { 00222 sizes[i] = temp_sizes[j++]; 00223 } 00224 } 00225 *ndim = child_ndim + 1; 00226 return (TRUE); 00227 00228 case INTRN_TRANSPOSE: 00229 (void) F90_Size_Walk(WN_kid0(expr),ndim,sizes); 00230 temp = sizes[0]; 00231 sizes[0] = sizes[1]; 00232 sizes[1] = temp; 00233 return (TRUE); 00234 00235 00236 case INTRN_MATMUL: 00237 { 00238 INT dim1,dim2; 00239 WN *size1[2],*size2[2]; 00240 F90_Size_Walk(WN_kid0(expr),&dim1,size1); 00241 F90_Size_Walk(WN_kid1(expr),&dim2,size2); 00242 00243 if (dim1 == 1) { 00244 // Vector-matrix 00245 *ndim = 1; 00246 sizes[0] = size2[0]; 00247 WN_DELETE_Tree(size1[0]); 00248 WN_DELETE_Tree(size2[1]); 00249 } else if (dim2 == 1) { 00250 // Matrix vector 00251 *ndim = 1; 00252 sizes[0] = size1[1]; 00253 WN_DELETE_Tree(size1[0]); 00254 WN_DELETE_Tree(size2[0]); 00255 } else { 00256 Is_True(dim1==2 && dim2 == 2,("Bad MATMUL")); 00257 // Matrix-Matrix 00258 *ndim = 2; 00259 sizes[1] = size1[1]; 00260 sizes[0] = size2[0]; 00261 WN_DELETE_Tree(size1[0]); 00262 WN_DELETE_Tree(size2[1]); 00263 } 00264 return (TRUE); 00265 } 00266 00267 case INTRN_ALL: 00268 case INTRN_ANY: 00269 case INTRN_COUNT: 00270 case INTRN_PRODUCT: 00271 case INTRN_SUM: 00272 case INTRN_MAXVAL: 00273 case INTRN_MINVAL: 00274 temp = WN_kid1(expr); 00275 dim = F90_Get_Dim(WN_kid1(expr)); 00276 if (dim==0) { 00277 /* Scalar reduction */ 00278 *ndim = 0; 00279 return (FALSE); 00280 } else { 00281 sized = F90_Size_Walk(WN_kid0(expr),&child_ndim,temp_sizes); 00282 if (dim == 1 && child_ndim == 1) { 00283 /* This is really a scalar reduction */ 00284 *ndim = 0; 00285 } else { 00286 dim = child_ndim - dim; 00287 for (i=0,j=0; i < child_ndim; i++) { 00288 if (i != dim) { 00289 sizes[j++] = temp_sizes[i]; 00290 } else { 00291 WN_DELETE_Tree(temp_sizes[i]); 00292 } 00293 } 00294 *ndim = child_ndim - 1; 00295 } 00296 return (*ndim != 0); 00297 } 00298 00299 00300 case INTRN_MAXLOC: 00301 case INTRN_MINLOC: 00302 temp = WN_kid1(expr); 00303 dim = F90_Get_Dim(WN_kid1(expr)); 00304 if (dim==0) { 00305 /* Scalar reduction */ 00306 *ndim = 1; 00307 (void) F90_Size_Walk(WN_kid0(expr),&child_ndim,temp_sizes); 00308 sizes[0] = WN_Intconst(MTYPE_I4,child_ndim); 00309 return (TRUE); 00310 } else { 00311 sized = F90_Size_Walk(WN_kid0(expr),&child_ndim,temp_sizes); 00312 dim = child_ndim - dim; 00313 for (i=0,j=0; i < child_ndim; i++) { 00314 if (i != dim) { 00315 sizes[j++] = temp_sizes[i]; 00316 } else { 00317 WN_DELETE_Tree(temp_sizes[i]); 00318 } 00319 } 00320 *ndim = child_ndim - 1; 00321 return (*ndim != 0); 00322 } 00323 00324 case INTRN_EOSHIFT: 00325 case INTRN_CSHIFT: 00326 return (F90_Size_Walk(WN_kid0(expr),ndim,sizes)); 00327 00328 case INTRN_PACK: 00329 /* We should only get here if VECTOR exists */ 00330 return (F90_Size_Walk(WN_kid2(expr),ndim,sizes)); 00331 00332 case INTRN_UNPACK: 00333 return (F90_Size_Walk(WN_kid1(expr),ndim,sizes)); 00334 00335 default: 00336 break; 00337 } 00338 default: 00339 break; 00340 } 00341 00342 /* Size all the children, looking for a sizable object */ 00343 sized = FALSE; 00344 numkids = WN_kid_count(expr); 00345 for (i=0; i < numkids; i++) { 00346 sized = F90_Size_Walk(WN_kid(expr,i),ndim,sizes); 00347 if (sized) break; 00348 } 00349 return (sized); 00350 } 00351 00352 /*================================================================ 00353 * 00354 * Utility routine for getting the rank of a tree 00355 * returns 0 for scalar, otherwise the rank of the TREE. 00356 * Works by calling F90_Size_Walk and cleaning up afterward. 00357 *================================================================ 00358 */ 00359 00360 INT F90_Rank_Walk(WN * tree) 00361 { 00362 INT rank; 00363 INT i; 00364 WN *temp_sizes[MAX_NDIM]; 00365 (void) F90_Size_Walk(tree,&rank,temp_sizes); 00366 00367 for (i=0; i < rank; i++) { 00368 WN_DELETE_Tree(temp_sizes[i]); 00369 } 00370 00371 return(rank); 00372 } 00373 00374 00375 00376 /* 00377 * F90_Wrap_ARREXP - Wrap an ARREXP node about an expression 00378 * 00379 * WN * F90_Lower_Wrap_ARREXP(WN * expr) 00380 * expr(input) - The expression to be wrapped 00381 * 00382 * returns an ARREXP node with all the sizes on it, or else 00383 * returns the expression if it's scalar. 00384 */ 00385 WN * F90_Wrap_ARREXP(WN * expr) 00386 { 00387 WN * r; 00388 INT i; 00389 INT ndim; 00390 WN *sizes[MAX_NDIM]; 00391 BOOL is_array_valued; 00392 TYPE_ID ty; 00393 00394 if (WN_operator(expr) == OPR_TRIPLET || //April) { 00395 WN_operator(expr) == OPR_SRCTRIPLET ) { 00396 /* Special case: TRIPLETS don't ever get ARRAYEXPs on top of them */ 00397 return (expr); 00398 } 00399 is_array_valued = F90_Size_Walk(expr, &ndim, sizes); 00400 if (is_array_valued) { 00401 ty = WN_rtype(expr); 00402 00403 # if 0 /*Keep ty as it was */ 00404 switch (ty) { 00405 case MTYPE_I1: 00406 case MTYPE_I2: 00407 case MTYPE_B: 00408 ty = MTYPE_I4; 00409 break; 00410 case MTYPE_U1: 00411 case MTYPE_U2: 00412 ty = MTYPE_U4; 00413 break; 00414 default: 00415 break; 00416 } 00417 # endif 00418 00419 r = WN_Create(OPCODE_make_op(OPR_ARRAYEXP,ty,MTYPE_V), 00420 ndim+1); 00421 WN_kid0(r) = expr; 00422 for (i=0; i<ndim; i++) { 00423 WN_kid(r,i+1) = sizes[i]; 00424 } 00425 } else { 00426 r = expr; 00427 } 00428 return (r); 00429 } 00430 00431 00432 /*================================================================ 00433 * 00434 * F90_wrap_cvtl 00435 * 00436 * Wrap a CVTL around an expressions for small types 00437 * 00438 *================================================================== 00439 */ 00440 00441 WN * 00442 F90_wrap_cvtl(WN * wn, TYPE_ID ty) 00443 { 00444 WN *r; 00445 00446 switch (ty) { 00447 case MTYPE_I1: 00448 r = WN_CreateCvtl(OPC_I4CVTL,8,wn); 00449 break; 00450 case MTYPE_I2: 00451 r = WN_CreateCvtl(OPC_I4CVTL,16,wn); 00452 break; 00453 case MTYPE_U1: 00454 r = WN_CreateCvtl(OPC_U4CVTL,8,wn); 00455 break; 00456 case MTYPE_U2: 00457 r = WN_CreateCvtl(OPC_U4CVTL,16,wn); 00458 break; 00459 default: 00460 r = wn; 00461 } 00462 00463 return (r); 00464 }