Open64: osprey/crayf90/sgi/cwh_dope.cxx Source File

00001 /*
00002  *  Copyright (C) 2006. QLogic Corporation. All Rights Reserved.
00003  */
00004 
00005 /*
00006  * Copyright 2003, 2004, 2005, 2006 PathScale, Inc.  All Rights Reserved.
00007  */
00008 
00009 /*
00010 
00011   Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.
00012 
00013   This program is free software; you can redistribute it and/or modify it
00014   under the terms of version 2 of the GNU General Public License as
00015   published by the Free Software Foundation.
00016 
00017   This program is distributed in the hope that it would be useful, but
00018   WITHOUT ANY WARRANTY; without even the implied warranty of
00019   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  
00020 
00021   Further, this software is distributed without any warranty that it is
00022   free of the rightful claim of any third person regarding infringement 
00023   or the like.  Any license provided herein, whether implied or 
00024   otherwise, applies only to this software file.  Patent licenses, if 
00025   any, provided herein do not apply to combinations of this program with 
00026   other software, or any other product whatsoever.  
00027 
00028   You should have received a copy of the GNU General Public License along
00029   with this program; if not, write the Free Software Foundation, Inc., 59
00030   Temple Place - Suite 330, Boston MA 02111-1307, USA.
00031 
00032   Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
00033   Mountain View, CA 94043, or:
00034 
00035   http://www.sgi.com
00036 
00037   For further information regarding this notice, see:
00038 
00039   http://oss.sgi.com/projects/GenInfo/NoticeExplan
00040 
00041 */
00042 
00043 
00044 /* ====================================================================
00045  * ====================================================================
00046  *
00047  * Module: cwh_dope
00048  * $Revision: 1.8 $
00049  * $Date: 05/09/27 07:36:38-07:00 $
00050  * $Author: scorrell@soapstone.pathscale.com $
00051  * $Source: 
00052  *
00053  * Revision history:
00054  *  dd-mmm-95 - Original Version
00055  *
00056  * Description: contains routines to manipulate dope vectors. Although
00057  *              the FLDs of the type contain offset and size information,
00058  *              these routines rely on defines to avoid repetition of 
00059  *              the same search. The definitions are in cwh_types.h.
00060  *
00061  * ====================================================================
00062  * ====================================================================
00063  */
00064 
00065 static const char *source_file = __FILE__;
00066 
00067 #ifdef _KEEP_RCS_ID
00068 /*REFERENCED*/
00069 static char *rcs_id = "$Source: crayf90/sgi/SCCS/s.cwh_dope.cxx $ $Revision: 1.8 $";
00070 #endif /* _KEEP_RCS_ID */
00071 
00072 /* sgi includes */
00073 
00074 #include "defs.h"
00075 #include "glob.h"  
00076 #include "symtab.h"
00077 #include "strtab.h"
00078 #include "errors.h"
00079 #include "config_targ.h"
00080 #include "wn.h"
00081 #include "wn_util.h"
00082 #include "f90_utils.h"
00083 
00084 /* Cray includes */
00085 
00086 #include "i_cvrt.h"
00087 
00088 
00089 /* conversion includes */
00090 
00091 #include "cwh_defines.h"
00092 #include "cwh_stk.h"
00093 #include "cwh_stmt.h"
00094 #include "cwh_types.h"
00095 #include "cwh_expr.h"
00096 #include "cwh_addr.h"
00097 
00098 
00099 #define opc_dim OPC_I8INTCONST
00100 
00101 static void  cwh_dope_store_bound(INT32 offset, INT32 dim) ;
00102 static void  cwh_dope_read_bound(INT32 offset, INT32 dim) ;
00103 #ifdef KEY /* Bug 6845 */
00104 static void  cwh_dope_initialize(ST *st, WN * wa, TY_IDX ty, WN *dp[DOPE_USED],
00105   WN **bd, INT16 num_bnds, WN **alloc_cpnt, int n_alloc_cpnt);
00106 #else /* KEY Bug 6845 */
00107 static void  cwh_dope_initialize(ST *st, WN * wa, TY_IDX ty, WN *dp[DOPE_USED],WN **bd, INT16 num_bnds ) ;
00108 #endif /* KEY Bug 6845 */
00109 static void  cwh_dope_store (ST *st, WN *wa, OFFSET_64 off, TY_IDX  ty, WN *rhs) ;
00110 
00111 
00112 /*===============================================
00113  *
00114  * fei_dv_def
00115  *
00116  * Dope vector initialization. The stack has
00117  * the dope fields, or nulls for empty slots
00118  * and these should be stored into the address
00119  * at the base of the stack. Unused fields in
00120  * the descriptor were not pushed onto the stack.
00121  *
00122  * Push a null operation for fei_store to ignore.
00123  *
00124  *===============================================
00125  */ 
00126 extern void 
00127 #ifdef KEY /* Bug 6845 */
00128 fei_dv_def(INT32 num_dims, INT32 n_alloc_cpnt )
00129 #else /* KEY Bug 6845 */
00130 fei_dv_def(INT32 num_dims )
00131 #endif /* KEY Bug 6845 */
00132 {
00133   WN * dp[DOPE_USED];
00134   WN * bd[BOUND_NM * MAX_ARY_DIMS];
00135   ST * st   ;
00136   WN * wa;
00137   FLD_IDX fld ;
00138   TY_IDX ty;
00139 
00140   INT16 n,i;
00141 
00142 #ifdef KEY /* Bug 6845 */
00143   WN ** alloc_cpnt = (WN **) alloca(n_alloc_cpnt * sizeof *alloc_cpnt);
00144   for (i = n_alloc_cpnt - 1; i >= 0; i -= 1) {
00145     alloc_cpnt[i] = cwh_expr_operand(NULL);
00146   }
00147 #endif /* KEY Bug 6845 */
00148 
00149   n = num_dims * BOUND_NM ;
00150 
00151   for( i = n-1 ; i >= 0  ; i --) 
00152     bd[i] = cwh_expr_operand(NULL);
00153 
00154   for( i = DOPE_USED-1 ; i >= 1 ; i--)
00155     dp[i] = cwh_expr_operand(NULL);
00156   
00157   dp[0] = cwh_expr_address(f_NONE);
00158 
00159   if (cwh_stk_get_class() == ST_item || cwh_stk_get_class() == ST_item_whole_array) {
00160      st = cwh_stk_pop_ST();
00161      wa = NULL;
00162      ty = 0;
00163 
00164   } else if (cwh_stk_get_class() == FLD_item) {
00165      fld = cwh_stk_pop_FLD();
00166      cwh_stk_push((void *) (INTPTR)fld,FLD_item);
00167      ty = FLD_type(FLD_HANDLE (fld));
00168      wa = cwh_expr_address(f_NONE);
00169      st = NULL;
00170 
00171   } else {
00172      wa = cwh_expr_address(f_NONE);
00173      st = NULL;
00174      ty = 0;
00175   }
00176 #ifdef KEY /* Bug 6845 */
00177   cwh_dope_initialize(st,wa,ty,dp,bd,n,alloc_cpnt,n_alloc_cpnt);
00178 #else /* KEY Bug 6845 */
00179   cwh_dope_initialize(st,wa,ty,dp,bd,n);
00180 #endif /* KEY Bug 6845 */
00181 
00182   /* These are going to be ignored */
00183   cwh_stk_push(st,ST_item);
00184   cwh_stk_push(NULL,WN_item);
00185 
00186 }
00187 
00188 /*===============================================
00189  *
00190  * fei_get_dv_low_bnd
00191  *
00192  * Get low bound for dimension dim.
00193  *
00194  *===============================================
00195  */ 
00196 extern void 
00197 fei_get_dv_low_bnd(INT32 dim,INT32 expand)
00198 {
00199   cwh_dope_read_bound(0,dim);
00200 }
00201 
00202 /*===============================================
00203  *
00204  * fei_get_dv_extent
00205  *
00206  * Get extent for dimension dim.
00207  *
00208  *===============================================
00209  */ 
00210 extern void 
00211 fei_get_dv_extent(INT32 dim,INT32 expand)
00212 {
00213   cwh_dope_read_bound(DOPE_bound_sz,dim);
00214 }
00215 
00216 /*===============================================
00217  *
00218  * fei_get_dv_str_mult
00219  *
00220  * Get extent for dimension dim.
00221  *
00222  *===============================================
00223  */ 
00224 extern void 
00225 fei_get_dv_str_mult(INT32 dim,INT32 expand)
00226 {
00227   cwh_dope_read_bound((2 * DOPE_bound_sz),dim);
00228 }
00229 
00230 /*===============================================
00231  *
00232  * fei_set_dv_low_bnd
00233  *
00234  * Set low bound for dimension dim.
00235  *
00236  *===============================================
00237  */ 
00238 extern void 
00239 fei_set_dv_low_bnd(INT32 dim)
00240 {
00241   cwh_dope_store_bound(0,dim);
00242 }
00243 
00244 /*===============================================
00245  *
00246  * fei_set_dv_extent
00247  *
00248  * Set extent for dimension dim.
00249  *
00250  *===============================================
00251  */ 
00252 extern void 
00253 fei_set_dv_extent(INT32 dim)
00254 {
00255   cwh_dope_store_bound(DOPE_bound_sz,dim);
00256 }
00257 
00258 /*===============================================
00259  *
00260  * fei_set_dv_str_mult
00261  *
00262  * Set extent for dimension dim.
00263  *
00264  *===============================================
00265  */ 
00266 extern void 
00267 fei_set_dv_str_mult(INT32 dim)
00268 {
00269   cwh_dope_store_bound((2 * DOPE_bound_sz),dim);
00270 }
00271 
00272 /*===============================================
00273  *
00274  * fei_dv_deref
00275  *
00276  * get the address of the space pointed to by
00277  * the dope. Assumes address is 1st field.
00278  * If it's an assumed shape dummy then load the
00279  * address first.
00280  *
00281  *===============================================
00282  */ 
00283 extern void 
00284 fei_dv_deref(TYPE result)
00285 {
00286   ST  * st ;
00287   WN  * wn ;
00288   WN  * wa;
00289   TY_IDX  ty, tp ;
00290   FLD_IDX  fld;
00291   TY_IDX dope_ty;
00292   char *field_name;
00293 
00294   if (cwh_stk_get_class() == ST_item || cwh_stk_get_class() == ST_item_whole_array) {
00295      st = cwh_stk_pop_ST();
00296      dope_ty = ST_type(st);
00297      
00298      if (ST_sclass(st) == SCLASS_FORMAL) {
00299   dope_ty = cwh_types_array_TY(dope_ty); 
00300      }
00301      ty = FLD_type(TY_fld(Ty_Table[dope_ty]));
00302      wn  = cwh_addr_load_ST(st,ADDR_OFFSET,ty);
00303 
00304   } else if (cwh_stk_get_class() == FLD_item) {
00305 
00306      field_name = cwh_stk_fld_name();
00307      fld = cwh_stk_pop_FLD();
00308      cwh_stk_push((void *)(INTPTR)fld,FLD_item);
00309      wn = cwh_expr_address(f_NONE);
00310      dope_ty = FLD_type(FLD_HANDLE (fld)); /* get the dope TY_IDX */
00311      ty = FLD_type(TY_fld(Ty_Table[dope_ty]));
00312      if (cwh_addr_f90_pointer_reference(wn)) {
00313   tp = cwh_types_mk_f90_pointer_ty(ty);
00314      } else {
00315   tp = cwh_types_make_pointer_type(dope_ty, FALSE);
00316      }
00317      
00318      wn = WN_CreateIload (OPCODE_make_op(OPR_ILOAD,Pointer_Mtype,Pointer_Mtype),
00319         ADDR_OFFSET,ty,tp,wn);
00320      SET_ARRAY_NAME_MAP(wn,field_name);
00321   } else {
00322 
00323      wn = cwh_expr_operand(NULL);
00324      dope_ty = 0;
00325   }
00326   cwh_stk_push_typed(wn,DEREF_item,dope_ty);
00327 }
00328 
00329 /*===============================================
00330  *
00331  * fei_get_dv_hdr_fld 
00332  *
00333  * get the appropriate field information from a dope vector
00334  * Assumes dope vector is on the stack.
00335  *
00336  *===============================================
00337  */ 
00338 extern void 
00339 #ifdef KEY /* Bug6845 */
00340 fei_get_dv_hdr_fld(dv_idx_type field)
00341 #else /* KEY Bug6845 */
00342 fei_get_dv_hdr_fld(INT32 field)
00343 #endif /* KEY Bug6845 */
00344 {
00345    INT32 offset;
00346    INT32 rshift;
00347    INT64 mask;
00348    TYPE_ID ty;
00349 
00350    ST *st;
00351 #ifdef KEY /* Bug 10177 */
00352    WN *wn = 0;
00353 #else /* KEY Bug 10177 */
00354    WN *wn;
00355 #endif /* KEY Bug 10177 */
00356 
00357    /* Get the information about the appropriate fields needed */
00358    cwh_types_get_dope_info(field, &offset, &rshift, &mask, &ty);
00359    
00360    switch(cwh_stk_get_class()) {
00361     case ST_item:
00362     case ST_item_whole_array:
00363       st = cwh_stk_pop_ST();
00364       wn = cwh_addr_load_ST(st,offset,Be_Type_Tbl(ty));
00365       break ;
00366       
00367     case WN_item:
00368     case WN_item_whole_array:
00369     case FLD_item:
00370       wn = cwh_expr_address(f_NONE);
00371       wn = cwh_addr_load_WN(wn,offset,Be_Type_Tbl(ty)); 
00372       break ;
00373       
00374     default:
00375       DevAssert((0),(" Odd dope load"));
00376       break;
00377    }
00378 
00379    /* See if we need to shift and mask */
00380    if (rshift != 0) {
00381       wn = cwh_expr_bincalc(OPR_LSHR,wn,WN_Intconst(MTYPE_I4,rshift));
00382    }
00383    if (mask != 0) {
00384       wn = cwh_expr_bincalc(OPR_BAND,wn,WN_Intconst(ty,mask));
00385    }
00386 
00387    cwh_stk_push(wn,WN_item);
00388 }
00389 
00390 /*===============================================
00391  *
00392  * fei_set_dv_hdr_fld 
00393  *
00394  * set the appropriate field information into a dope vector
00395  * Assumes dope vector is on the stack.
00396  *
00397  *===============================================
00398  */ 
00399 extern void 
00400 #ifdef KEY /* Bug6845 */
00401 fei_set_dv_hdr_fld(dv_idx_type field)
00402 #else /* KEY Bug6845 */
00403 fei_set_dv_hdr_fld(INT32 field)
00404 #endif /* KEY Bug6845 */
00405 {
00406    INT32 offset;
00407    INT32 rshift;
00408    INT64 mask,mask_complement;
00409    TYPE_ID ty;
00410    TYPE_ID addr_ty;
00411    BOOL needs_load;
00412    FLD_HANDLE fl;
00413 
00414    ST *st;
00415    WN *wn;
00416    WN *arg,*old_value;
00417 
00418    /* Get the information about the appropriate fields needed */
00419    cwh_types_get_dope_info(field, &offset, &rshift, &mask, &ty);
00420    mask_complement = mask;
00421    needs_load = FALSE;
00422 
00423    /* Special cases for 1 and 9 base_address and orig_base */
00424 #ifdef KEY /* Bug6845 */
00425    if (field == DV_BASE_IDX || field == DV_ORIG_BASE_IDX)
00426 #else /* KEY Bug6845 */
00427    if (field == 1 || field == 9)
00428 #endif /* KEY Bug6845 */
00429    {
00430       arg = cwh_expr_address(f_NONE);
00431    } else {
00432       arg = cwh_expr_operand(NULL);
00433    }
00434 
00435    /* Get arg in the right place if need be */
00436    if (mask != 0) {
00437       arg = cwh_expr_bincalc(OPR_BAND,arg,WN_Intconst(ty,mask));
00438       needs_load = TRUE;
00439    }
00440    if (rshift != 0) {
00441       arg = cwh_expr_bincalc(OPR_SHL,arg,WN_Intconst(MTYPE_I4,rshift));
00442       mask_complement <<= rshift;
00443       needs_load = TRUE;
00444    }
00445    mask_complement = ~mask_complement;
00446       
00447 #ifdef KEY /* Bug 8128 */
00448    int tos_class = cwh_stk_get_class();
00449 #endif /* KEY Bug 8128 */
00450    switch(cwh_stk_get_class()) {
00451     case ST_item:
00452     case ST_item_whole_array:
00453 
00454       addr_ty = cwh_stk_get_TY();
00455 
00456       st = cwh_stk_pop_ST();
00457 
00458       if (! addr_ty) {
00459          addr_ty = ST_type(st);
00460       }
00461 
00462       if (needs_load) {
00463    old_value = cwh_addr_load_ST(st,offset,Be_Type_Tbl(ty));
00464    if (mask != 0) {
00465       old_value = cwh_expr_bincalc(OPR_BAND,old_value,WN_Intconst(ty,mask_complement));
00466       arg = cwh_expr_bincalc(OPR_BIOR,arg,old_value);
00467    }
00468       }
00469 
00470 #ifdef KEY /* Bug6845 */
00471       if (field == DV_BASE_IDX || field == DV_ORIG_BASE_IDX)
00472 #else /* KEY Bug6845 */
00473       if (field == 1 || field == 9)
00474 #endif /* KEY Bug6845 */
00475       {
00476          if (TY_kind(addr_ty) == KIND_POINTER) addr_ty = TY_pointed(addr_ty);
00477 
00478          /* addr_ty should be the TY of a dope vector Dope */
00479 
00480          TY & tt = Ty_Table[addr_ty];
00481          fl = TY_fld(tt);
00482          addr_ty = FLD_type(fl);
00483          DevAssert((TY_kind(addr_ty) == KIND_POINTER),(" base not pointer "));
00484       } else {
00485          addr_ty = Be_Type_Tbl(ty);
00486       }
00487       cwh_addr_store_ST(st,offset,addr_ty,arg);
00488       break ;
00489       
00490     case WN_item:
00491     case WN_item_whole_array:
00492     case FLD_item:
00493 
00494       if (cwh_stk_get_class() == FLD_item) {
00495          addr_ty = cwh_stk_get_FLD_TY();
00496       } else {
00497          addr_ty = cwh_stk_get_TY();
00498       }
00499 
00500       wn = cwh_expr_address(f_NONE);
00501 
00502       if (! addr_ty) {
00503          addr_ty = cwh_types_WN_TY(wn, TRUE);
00504       }
00505 
00506       if (needs_load) {
00507    old_value = cwh_addr_load_WN(WN_COPY_Tree(wn),offset,Be_Type_Tbl(ty));
00508    if (mask != 0) {
00509       old_value = cwh_expr_bincalc(OPR_BAND,old_value,WN_Intconst(ty,mask_complement));
00510       arg = cwh_expr_bincalc(OPR_BIOR,arg,old_value);
00511    }
00512       }
00513 
00514 #ifdef KEY /* Bug6845 */
00515       if (field == DV_BASE_IDX || field == DV_ORIG_BASE_IDX)
00516 #else /* KEY Bug6845 */
00517       if (field == 1 || field == 9)
00518 #endif /* KEY Bug6845 */
00519       {
00520          if (TY_kind(addr_ty) == KIND_POINTER) addr_ty = TY_pointed(addr_ty);
00521 
00522          /* addr_ty should be the TY of a dope vector Dope */
00523 
00524          TY & tt = Ty_Table[addr_ty];
00525          fl = TY_fld(tt);
00526          addr_ty = FLD_type(fl);
00527          DevAssert((TY_kind(addr_ty) == KIND_POINTER),(" base not pointer "));
00528       } else {
00529          addr_ty = Be_Type_Tbl(ty);
00530       }
00531 #ifdef KEY /* Bug 8128 */
00532       /*
00533        * Special case: array of structure containing a member of type pointer.
00534        * Can't generate a whole-array or array-section reference to such a
00535        * member explicitly in the source program because you get error 408,
00536        * "This pointer is to the right of a part-ref with nonzero rank." But
00537        * it comes up implicitly when the front end tries to generate dope info.
00538        */
00539       if (FLD_item == tos_class && 0 < WN_kid_count(wn) &&
00540          OPR_ARRSECTION == WN_operator(WN_kid(wn, 0))) {
00541    wn = F90_Wrap_ARREXP(wn) ;
00542       }
00543 #endif /* KEY Bug 8128 */
00544       cwh_addr_store_WN(wn,offset,addr_ty,arg); 
00545       break ;
00546       
00547     default:
00548       DevAssert((0),(" Odd dope store"));
00549       break;
00550    }
00551 }
00552 
00553 
00554 
00555 /*===============================================
00556  *
00557  * arrsection_to_array 
00558  *
00559  * Turn ARRSECTION nodes into ARRAY nodes pointing at the 
00560  * base address of the arrsection. Expects as input an ARRSECTION
00561  * or ARRAY node. Does its work in place.
00562  * 
00563  *===============================================
00564  */ 
00565 static void arrsection_to_array(WN *addr)
00566 {
00567    INT i,ndim;
00568    WN *temp;
00569    OPERATOR opr;
00570 
00571    opr = WNOPR(addr);
00572 
00573    if (opr == OPR_ARRSECTION || opr == OPR_ARRAY) {
00574       WN_set_opcode(addr,OPCODE_make_op(OPR_ARRAY,Pointer_Mtype,MTYPE_V));
00575       arrsection_to_array(WN_kid0(addr));
00576       ndim = (WN_kid_count(addr)-1)/2;
00577       for (i=ndim+1; i < 2*ndim + 1; i++) {
00578    if (WNOPR(WN_kid(addr,i)) == OPR_TRIPLET) {
00579       temp = WN_kid(addr,i);
00580       WN_kid(addr,i) = WN_kid0(temp);
00581       WN_DELETE_Tree(WN_kid1(temp));
00582       WN_DELETE_Tree(WN_kid2(temp));
00583       WN_Delete(temp);
00584    }
00585       }
00586    } else if (opr == OPR_ADD || opr == OPR_MPY || opr == OPR_SUB) {
00587       /* character(*) case */
00588       arrsection_to_array(WN_kid0(addr));
00589       arrsection_to_array(WN_kid1(addr));
00590    }
00591    return;
00592 }
00593 
00594 /*===============================================
00595  *
00596  * fei_dv_ptr_asg 
00597  *
00598  * Set the address field in a dope vector.
00599  * Assumes dope vector is on the stack.
00600  *
00601  *===============================================
00602  */ 
00603 extern void 
00604 fei_dv_ptr_asg(void)
00605 {
00606    WN *addr;
00607    
00608    /* Probably should set the address/taken/saved bit */
00609    addr = cwh_expr_address(f_T_SAVED);
00610    arrsection_to_array(addr);
00611    cwh_stk_push(addr,WN_item);
00612 #ifdef KEY /* Bug6845 */
00613    fei_set_dv_hdr_fld(DV_BASE_IDX); /* store it */
00614 #else /* KEY Bug6845 */
00615    fei_set_dv_hdr_fld(1); /* store it */
00616 #endif /* KEY Bug6845 */
00617 }
00618 
00619 /*===============================================
00620  *
00621  * cwh_dope_read_bound
00622  *
00623  * Read a  bound of dimension dim. The offset is
00624  * the extra for a lb,extent or stride, in addition
00625  * to the basic dimension,
00626  *
00627  *===============================================
00628  */ 
00629 static void
00630 cwh_dope_read_bound(INT32 offset, INT32 dim)
00631 {
00632   WN  * wa ;
00633 #ifdef KEY /* Bug 10177 */
00634   WN  * wn = 0;
00635 #else /* KEY Bug 10177 */
00636   WN  * wn ;
00637 #endif /* KEY Bug 10177 */
00638   ST  * st ;
00639   WN_OFFSET off;
00640 
00641   off = DOPE_dim_offset + offset + (DIM_SZ * (dim-1)) ;
00642 
00643   switch(cwh_stk_get_class()) {
00644   case ST_item:
00645   case ST_item_whole_array:
00646     st = cwh_stk_pop_ST();
00647     wn = cwh_addr_load_ST(st,off,DOPE_bound_ty);
00648     break ;
00649 
00650   case WN_item:
00651   case WN_item_whole_array:
00652   case FLD_item:
00653     wa = cwh_expr_address(f_NONE);
00654     wn = cwh_addr_load_WN(wa,off,DOPE_bound_ty); 
00655     break ;
00656 
00657   default:
00658     DevAssert((0),(" Odd dope load"));
00659     break;
00660   }
00661 
00662   wn = cwh_convert_to_ty(wn,cwh_bound_int_typeid);
00663 
00664   cwh_stk_push(wn,WN_item);
00665 }
00666 
00667 /*===============================================
00668  *
00669  * cwh_dope_store_bound
00670  *
00671  * Store a bound of dimension dim. The offset is 
00672  * the extra for a lb,extent or stride, in addition
00673  * to the basic dimension,
00674  *
00675  *===============================================
00676  */ 
00677 static void
00678 cwh_dope_store_bound(INT32 offset, INT32 dim)
00679 {
00680   WN  * wn ;
00681   WN  * wa ;
00682   ST  * st ;
00683   OFFSET_64 off;
00684 
00685   off = DOPE_dim_offset + offset + (DIM_SZ * (dim-1)) ;
00686   wn  = cwh_expr_operand(NULL);
00687 
00688   switch(cwh_stk_get_class()) {
00689   case ST_item:
00690   case ST_item_whole_array:
00691     st = cwh_stk_pop_ST();
00692     cwh_addr_store_ST(st,off,DOPE_bound_ty,wn);
00693     break ;
00694 
00695   case WN_item:
00696   case WN_item_whole_array:
00697   case FLD_item:
00698     wa = cwh_expr_address(f_NONE);
00699     cwh_addr_store_WN(wa,off,DOPE_bound_ty,wn); 
00700     break ;
00701 
00702   default:
00703     DevAssert((0),(" Odd dope store"));
00704     break;
00705   }
00706 }
00707 
00708 
00709 /*================================================================
00710  *
00711  * cwh_dope_get_dope_fudge_factor
00712  *
00713  * This routine returns 1 for INTEGER(1) base types, 2 for INTEGER(2)
00714  * base types, and 4 for everything else. It is needed to interpret
00715  * the stride in dope vectors.
00716  *
00717  * Stride is in word (4 byte) elements for types whose size is >= I4, 
00718  * unless it's a character-only thing, when bytes are used. 
00719  * I1,I2,L1,L2 get element size stride (1 or 2 bytes).
00720  *
00721  *================================================================
00722  */
00723 
00724 static INT64
00725 cwh_dope_get_dope_fudge_factor(TY_IDX ty)
00726 {
00727 #ifdef KEY /* Bug 10177 */
00728    TY_IDX base_ty = 0;
00729 #else /* KEY Bug 10177 */
00730    TY_IDX base_ty;
00731 #endif /* KEY Bug 10177 */
00732    TYPE_ID t;
00733 
00734    TY& tt = Ty_Table[ty];
00735    if (TY_kind(ty) == KIND_ARRAY) {
00736       return (cwh_dope_get_dope_fudge_factor(TY_etype(tt))); 
00737    } else if (TY_kind(ty) == KIND_STRUCT) {
00738       if (TY_is_packed(tt)) return(1);
00739       return (4);
00740    } else if (TY_kind(ty) == KIND_SCALAR) {
00741       base_ty = ty;
00742    } else {
00743       DevAssert((0),("Do not know what to do with type"));
00744    }
00745 
00746    if (TY_is_character(Ty_Table[base_ty])) {
00747       return (1);
00748    }
00749    t = TY_mtype(base_ty);
00750    if (MTYPE_byte_size(t) < 4) {
00751       return (MTYPE_byte_size(t));
00752    }
00753    return (4);
00754 }
00755 
00756 /*===============================================
00757  *
00758  * cwh_dope_from_expression
00759  *
00760  * expr must be an ILOAD, an MLOAD, or any expression which represents the
00761  * address of something. If array is NULL expr must contain exactly one
00762  * ARRSECTION node. If array is non-null, expr must not contain an
00763  * ARRSECTION. If char_len is non-null, the dope vector will be made to
00764  * represent a character expression of length char_len. 
00765  * 
00766  * tarray is the TY of the array object the dope is for - the 
00767  * base expression may be from a structure.
00768  *
00769  *================================================================
00770  */
00771 
00772 extern WN * 
00773 cwh_dope_from_expression(WN *expr, WN *array, WN *char_len, TY_IDX tarray,
00774 WN *craytype_wn)
00775 {
00776   WN * wn ;
00777   WN * wt ;
00778   ST * st ;
00779   TY_IDX  tc ;
00780   TY_IDX  ty ;
00781   WN * se;
00782   WN * lower_bound;
00783   WN * stride_mult_accum;
00784   WN * address_fixup;
00785   INT64 element_size_multiplier;
00786   INT64 craytype;
00787   WN_ESIZE element_size;
00788   BOOL     non_contig;
00789   INT64  offset;
00790   
00791   FLD_IDX  fl ;
00792 
00793   WN * dp[DOPE_USED];
00794   WN * bd[BOUND_NM * MAX_ARY_DIMS];
00795 
00796   INT32 nd ;
00797   INT16 i,j ;
00798 
00799   if (WNOPR(expr) == OPR_ILOAD || WNOPR(expr) == OPR_MLOAD) {
00800      /* 
00801       * Get the offset and the scalar type, 
00802       * then clean up expr and set it to point to tha address child.
00803       */
00804      offset = WN_offset(expr);
00805      if (WN_kid_count(expr)==2) {
00806   WN_DELETE_Tree(WN_kid1(expr));
00807      }
00808      se = WN_kid0(expr);
00809      WN_Delete(expr);
00810      expr = se;
00811   } else {
00812      offset = 0;
00813   }
00814 
00815   se = cwh_addr_find_section(expr,p_RETURN_SECTION);
00816   if (!se) {
00817      se = array;
00818   }
00819 
00820   DevAssert((se),("Can't find an array section or an array to use"));
00821 #ifdef KEY
00822   DevAssert((tarray != 0),("Missing TY"));
00823 #else
00824   DevAssert((tarray != NULL),("Missing TY"));
00825 #endif
00826 
00827   element_size = WN_element_size(se);
00828   if (element_size < 0) {
00829      element_size = -element_size;
00830      non_contig = TRUE;
00831   } else {
00832      non_contig = FALSE;
00833   }
00834   nd = WN_num_dim(se);
00835 
00836   /* Step 1: get the stride multiplier scale factor */
00837   element_size_multiplier = element_size/cwh_dope_get_dope_fudge_factor(tarray);
00838   if (element_size_multiplier == 0) element_size_multiplier = 1; 
00839 
00840   if (char_len) {
00841      dp[1] = WN_COPY_Tree(char_len);
00842      /* The stride multiplier is in bytes for this type */
00843      stride_mult_accum = WN_Intconst(cwh_bound_int_typeid,element_size);
00844   } else {
00845      dp[1] = WN_Intconst(Pointer_Mtype,element_size*8);
00846      stride_mult_accum = WN_Intconst(cwh_bound_int_typeid,element_size_multiplier);
00847   }
00848 
00849   /* Step 2, build up the lbound, extents, and stride_multiplier fields, 
00850    * and alter the section node to be an ARRAY node.
00851    * bounds from section - these are always
00852    * simple triplets or scalar subscripts. 
00853   */
00854   
00855   j = 0 ;
00856 
00857   for (i = 2*nd; i >= nd+1 ; i --) {
00858      wt = WN_kid(se,i) ;
00859      if (WNOPR(wt) == OPR_TRIPLET) {
00860   /* Replace a TRIPLET node in the section with its lower bound */
00861   WN_kid(se,i) = WN_kid0(wt);
00862   /* Copy the extent to the dope vector */
00863   bd[j+1] = cwh_expr_bincalc(OPR_MAX,WN_kid2(wt),WN_Zerocon(cwh_bound_int_typeid));
00864   if (non_contig) {
00865      bd[j+2] = cwh_expr_bincalc(OPR_MPY,WN_COPY_Tree(WN_kid(se,i-nd)),
00866                     WN_kid1(wt));
00867      /* Correct for character, etc, in derived types */
00868      bd[j+2] = cwh_expr_bincalc(OPR_MPY,bd[j+2],WN_Intconst(cwh_bound_int_typeid,
00869                   element_size_multiplier));
00870   } else {
00871      bd[j+2] = cwh_expr_bincalc(OPR_MPY,WN_kid1(wt),WN_COPY_Tree(stride_mult_accum));
00872   }
00873   /* Don't need the triplet anymore */
00874   WN_Delete(wt);
00875      } else {
00876   /* Extent = 1 */
00877   bd[j+1] = WN_Intconst(cwh_bound_int_typeid,1);
00878   if (non_contig) {
00879      bd[j+2] = WN_COPY_Tree(WN_kid(se,i-nd));
00880      /* Correct for character, etc, in derived types */
00881      bd[j+2] = cwh_expr_bincalc(OPR_MPY,bd[j+2],WN_Intconst(cwh_bound_int_typeid,
00882                   element_size_multiplier));
00883   } else {
00884      bd[j+2] = WN_COPY_Tree(stride_mult_accum);
00885   }
00886      }
00887      bd[j] = WN_Intconst(cwh_bound_int_typeid,1);
00888      j+= BOUND_NM;
00889      if (i != nd+1 && !non_contig) {
00890   stride_mult_accum = cwh_expr_bincalc(OPR_MPY,stride_mult_accum,WN_COPY_Tree(WN_kid(se,i-nd)));
00891      }
00892   }
00893   WN_DELETE_Tree(stride_mult_accum);
00894 
00895   /* Turn the ARRSECTION into an ARRAY node */ 
00896   WN_set_opcode(se,OPCODE_make_op(OPR_ARRAY,Pointer_Mtype,MTYPE_V));
00897   /* Add the constant offset to the expression */
00898   expr = cwh_expr_bincalc(OPR_ADD,expr,WN_Intconst(Pointer_Mtype,offset));
00899   
00900   /* Set the base address */
00901   dp[0] = expr;
00902 
00903   /* Step 3, fill in the flag fields of the dope vector */
00904   /* contig, ptr flags, rank; assume non-contiguous, associated non-pointer */
00905 
00906   dp[2] = WN_Intconst(MTYPE_U4,1); /* associated */
00907   dp[3] = WN_Intconst(MTYPE_U4,0); /* allocated by pointer */
00908   dp[4] = WN_Intconst(MTYPE_U4,0); /* p_or_a */
00909   dp[5] = WN_Intconst(MTYPE_U4,0); /* contig */
00910   dp[6] = WN_Intconst(MTYPE_U4,nd);
00911 
00912   if (craytype_wn == NULL) {
00913       /* type code  **FIX */
00914       if (!char_len) {
00915          craytype = cwh_cray_type_from_TY(tarray);
00916       } else {
00917          f90_type_t *f90_type_ptr;
00918          f90_type_ptr = (f90_type_t *)&craytype;
00919          craytype = 0;
00920          f90_type_ptr->type = 6;
00921          f90_type_ptr->int_len = 8;
00922       }
00923       craytype_wn = WN_Intconst(MTYPE_U8,craytype);
00924   }
00925 
00926   dp[7] = WN_COPY_Tree(craytype_wn);
00927 
00928   /* original base and address - 0 unless allocatable */
00929   dp[8] = WN_Intconst(Pointer_Mtype,0);
00930   dp[9] = WN_Intconst(Pointer_Mtype,0);
00931 
00932   /* Create the dope vector */
00933   ty = cwh_types_dope_TY(nd,tarray,FALSE,FALSE,
00934 #ifdef KEY /* Bug6845 */
00935     /* I hope this can't be an array of derived types having allocatable
00936      * components. If that's ever possible, we need to figure out from the
00937      * source type how many allocatable components there are. */
00938     0
00939 #endif /* KEY Bug 6845 */
00940     );
00941   wn = cwh_expr_temp(ty,NULL,f_T_PASSED);
00942 #ifdef KEY /* Bug 6845 */
00943   dp[10] = WN_Intconst(MTYPE_U4, 0);
00944   cwh_dope_initialize(WN_st(wn),NULL,0,dp,bd,nd*BOUND_NM,0,0);  
00945 #else /* KEY Bug 6845 */
00946   cwh_dope_initialize(WN_st(wn),NULL,0,dp,bd,nd*BOUND_NM);  
00947 #endif /* KEY Bug 6845 */
00948   return(wn);
00949 
00950 }
00951 
00952 /*===============================================
00953  *
00954  * cwh_dope_initialize_body
00955  *
00956  * Given the ST of a dope vector, initialize
00957  * all fields except the bounds.
00958  *
00959  *===============================================
00960  */ 
00961 static void
00962 #ifdef KEY /* Bug 6845 */
00963 cwh_dope_initialize(ST *st, WN *wa, TY_IDX dope_ty, WN *dp[DOPE_USED],WN **bd,
00964   INT16 num_bnds, WN **alloc_cpnt, INT16 n_alloc_cpnt)
00965 #else /* KEY Bug 6845 */
00966 cwh_dope_initialize(ST *st, WN *wa, TY_IDX dope_ty, WN *dp[DOPE_USED],WN **bd, INT16 num_bnds )
00967 #endif /* KEY Bug 6845 */
00968 {
00969   INT16  i ;
00970   INT16 sz ;
00971 
00972   FLD_HANDLE  fli ;
00973   FLD_HANDLE  fl ;
00974   FLD_HANDLE  ft ;
00975   TY_IDX ty ;
00976   WN  * wr ;
00977   WN  * wt ;
00978 
00979 #ifdef KEY /* Bug 10177 */
00980   OFFSET_64 off = 0;
00981 #else /* KEY Bug 10177 */
00982   OFFSET_64 off;
00983 #endif /* KEY Bug 10177 */
00984   OFFSET_64 invar_off;
00985   INT shift;
00986 
00987   if (dope_ty == 0) {
00988      if ( wa == NULL ) {
00989   fli = TY_fld(Ty_Table[ST_type(st)]);
00990      } else {
00991   fli = TY_fld(Ty_Table[cwh_types_WN_TY(wa, FALSE)]);
00992      }
00993   } else {
00994      fli = TY_fld(Ty_Table[dope_ty]);
00995   }
00996 
00997   /* address, element len */
00998 
00999   if (dp[0] != NULL )
01000       cwh_dope_store(st,wa,FLD_ofst(fli),FLD_type(fli),dp[0]) ;
01001 
01002   fli = FLD_next(fli);
01003   invar_off = FLD_ofst(fli);
01004   fl = TY_fld(Ty_Table[FLD_type(fli)]);
01005   if (dp[1] != NULL )
01006      cwh_dope_store(st,wa,invar_off + FLD_ofst(fl),FLD_type(fl),dp[1]);
01007   
01008   /* assoc, ptr_alloc,ptr_or_a, a_contig */
01009   
01010   wr = NULL;
01011   fl = FLD_next(fl);
01012   sz = MTYPE_size_best(TY_mtype(FLD_type(fl)));
01013   ft = fl ;
01014   
01015 # if (defined(linux) || defined(BUILD_OS_DARWIN))
01016   {
01017     dope_header1_type dh1;
01018  
01019   // assoc 
01020     if (dp[2] != NULL)
01021       dh1.assoc = WN_const_val(dp[2]);
01022     else
01023       dh1.assoc = 0;
01024      ft = FLD_next(ft);
01025 
01026   // ptr_alloc
01027 
01028     if (dp[3] != NULL)
01029       dh1.ptr_alloc = WN_const_val(dp[3]);
01030     else
01031       dh1.ptr_alloc = 0;
01032      ft = FLD_next(ft);
01033 
01034   // ptr_or_a
01035 
01036     if (dp[4] != NULL)
01037       dh1.p_or_a = WN_const_val(dp[4]);
01038     else
01039       dh1.p_or_a = 0;
01040      ft = FLD_next(ft);
01041 
01042   // a_contig
01043     if (dp[5] != NULL)
01044       dh1.a_contig = WN_const_val(dp[5]);
01045     else
01046       dh1.a_contig = 0;
01047      ft = FLD_next(ft);
01048 
01049 #ifdef KEY /* Bug 6845 */
01050   // alloc_cpnt
01051     dh1.alloc_cpnt = WN_const_val(dp[10]);
01052     ft = FLD_next(ft);
01053 #endif /* KEY Bug 6845 */
01054 
01055     dh1.unused = 0;
01056 
01057     wr = WN_Intconst(MTYPE_U4,*(UINT32*)&dh1);
01058 
01059   }
01060 # else
01061   for (i = 0 ; i < 4 ; i ++ ) {
01062      if (dp[i+2] != NULL ) {
01063   shift = sz - FLD_bofst(ft) - FLD_bsize(ft);
01064   if (shift != 0) {
01065      wt = WN_Intconst(MTYPE_U4,shift);
01066      wt = cwh_expr_bincalc(OPR_SHL,dp[i+2],wt);
01067   } else {
01068      wt = dp[i+2];
01069   }
01070   
01071   if (wr == NULL) 
01072      wr = wt ;
01073   else
01074      wr = cwh_expr_bincalc(OPR_BIOR,wr,wt);
01075      }
01076      ft = FLD_next(ft);
01077   }
01078 # endif
01079   
01080   if (wr != NULL) 
01081      cwh_dope_store(st,wa,invar_off + FLD_ofst(fl),FLD_type(fl),wr);    
01082   
01083   /* ignore unused fields & add in rank */
01084   fl = FLD_next(ft);
01085   
01086   if (dp[6] != NULL ) {
01087 # if (defined(linux) || defined(BUILD_OS_DARWIN))
01088      dope_header2_type dh2;
01089 
01090      dh2.unused = 0;
01091      dh2.n_dim = WN_const_val(dp[6]);
01092      wr = WN_Intconst(MTYPE_U4,*(UINT32*)&dh2);
01093      cwh_dope_store(st,wa,invar_off + FLD_ofst(fl),FLD_type(fl),wr);
01094 # else
01095      cwh_dope_store(st,wa,invar_off + FLD_ofst(fl),FLD_type(fl),dp[6]);    
01096 # endif
01097   }
01098   
01099 //  /* Initialize the first four unused bytes of the f90_type structure */
01100 //  fl = FLD_next(fl);
01101 //  cwh_dope_store(st,wa,invar_off + FLD_ofst(fl),FLD_type(fl),
01102 //     WN_Intconst(MTYPE_U4,0));
01103   
01104   /* type code */
01105   fl = FLD_next(fl);
01106   
01107   if (dp[7] != NULL) 
01108      cwh_dope_store(st,wa,invar_off + FLD_ofst(fl),FLD_type(fl),dp[7]);    
01109   
01110   /* original base and address */
01111   
01112   fl = FLD_next(fl);
01113   if (dp[8] != NULL) 
01114      cwh_dope_store(st,wa,invar_off + FLD_ofst(fl),FLD_type(fl),dp[8]);    
01115   
01116   fl = FLD_next(fl);
01117   if (dp[9] != NULL) 
01118      cwh_dope_store(st,wa,invar_off + FLD_ofst(fl),FLD_type(fl),dp[9]);
01119   
01120   
01121   /* add bounds - assumes all same size */
01122   
01123   if (num_bnds > 0 ) {
01124      
01125      fli  = FLD_next(fli) ;
01126      off = FLD_ofst(fli) ;
01127      ty  = DOPE_bound_ty     ;
01128      sz  = bit_to_byte(MTYPE_size_best(TY_mtype(ty)));
01129      
01130      for (i = 0 ; i < num_bnds  ; i ++ ) {
01131   if (bd[i] != NULL ) 
01132      cwh_dope_store(st,wa,off,ty,bd[i]);
01133       off += sz ;
01134      }
01135   }
01136 
01137 #ifdef KEY /* Bug 6845 */
01138   /* If this is an allocatable array whose element is a derived type having
01139    * component(s) which are themselves allocatable, emit a list of byte offsets
01140    * within the structure to each of the allocatable components, preceded by
01141    * a count of the number of offsets.
01142    */
01143   if (n_alloc_cpnt) {
01144 
01145      cwh_dope_store(st,wa,off,DOPE_bound_ty,
01146        WN_Intconst(MTYPE_U4, n_alloc_cpnt));
01147      off += DOPE_bound_sz;
01148 
01149      for (i = 0; i < n_alloc_cpnt; i += 1) {
01150        cwh_dope_store(st,wa,off,DOPE_bound_ty,alloc_cpnt[i]);
01151        off += DOPE_bound_sz;
01152      }
01153   }
01154 #endif /* KEY Bug 6845 */
01155 }
01156 
01157 /*===============================================
01158  *
01159  * cwh_dope_store
01160  *
01161  * Utility routine to store dope fields for 
01162  * an address, or an ST.
01163  *
01164  *===============================================
01165  */ 
01166 static void
01167 cwh_dope_store (ST *st, WN *wa, OFFSET_64 off, TY_IDX  ty, WN *rhs)
01168 {
01169   if (wa == NULL) {
01170      cwh_addr_store_ST(st,off,ty,rhs);
01171   } else {
01172      wa = F90_Wrap_ARREXP(WN_COPY_Tree(wa));
01173      cwh_addr_store_WN(wa,off,ty,rhs);
01174   }
01175 }