|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
|
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 static char USMID[] = "\n@(#)3.0_pl/sources/mifcvrt.c 3.8 01/17/97 12:00:48\n"; 00037 00038 00039 00040 # include "defines.h" /* Machine dependent ifdefs */ 00041 00042 # include "host.m" /* Host machine dependent macros. */ 00043 # include "host.h" /* Host machine dependent header. */ 00044 # include "target.m" /* Target machine dependent macros. */ 00045 # include "target.h" /* Target machine dependent header. */ 00046 00047 # include "globals.m" 00048 # include "tokens.m" 00049 # include "sytb.m" 00050 # include "debug.m" 00051 # include "s_globals.m" 00052 00053 # include "globals.h" 00054 # include "tokens.h" 00055 # include "sytb.h" 00056 # include "p_globals.h" 00057 00058 # if defined(_STANDALONE_FRONT_END) 00059 00060 # include "asm.h" 00061 00062 # include <sys/types.h> 00063 # include <sys/stat.h> 00064 00065 # if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX) 00066 # include <sys/target.h> 00067 # endif 00068 00069 # include <mif_dialect.h> 00070 # include <mif.h> 00071 # include <mif_util.h> 00072 # include <mif_io.h> 00073 00074 00075 /*****************************************************************\ 00076 |* Function prototypes of static functions declared in this file *| 00077 \*****************************************************************/ 00078 00079 enum evcontext { value, address }; 00080 enum proc_call_class { Definition, Parent, Imported }; 00081 00082 static void create_option_tbl(void); 00083 static void cvrt_proc_to_mif(FILE *, char *); 00084 static void cvrt_sytb_to_mif(int); 00085 static void cvrt_exp_to_mif(mopd_t *, mblk_t*, int, fld_type, 00086 mopnflag_t, enum evcontext); 00087 static void cvrt_ir_to_mif(int); 00088 static int get_basic_type(int); 00089 static int get_ptr_type(fld_type, int); 00090 static int get_type_idx(int); 00091 static void cvrt_dummy_procedure(int); 00092 static int cvrt_darg_list(int); 00093 static void cvrt_proc(int, int, enum proc_call_class); 00094 static int cvrt_derived_type(int); 00095 static int cvrt_label(int, mopnflag_t, mpos_t); 00096 static int cvrt_attr_ntry(int); 00097 static void cvrt_const (char *, int, int, mopd_t *); 00098 static int fold_exp(int, fld_type, int *, int *, int *); 00099 static void cvrt_data_impl_do(int, fld_type); 00100 static void write_mod_tbl_file_name(FILE *); 00101 static void init_subprog_info(int); 00102 mopd_t mif_opn_add(mblk_t *, mop_t, int, mpos_t, unsigned long, 00103 mopd_t, mopd_t, mopd_t); 00104 00105 00106 /*************************************************************\ 00107 |* Things that really should be in header files, but aren't. *| 00108 \*************************************************************/ 00109 00110 extern char frontend_version[]; 00111 extern char *getenv (const char *); 00112 00113 00114 /******************************************\ 00115 |* Local data structures for this module. *| 00116 \******************************************/ 00117 00118 static msubprog_t msp; /* MIF subprogram under construction */ 00119 static char hostname[MACHINENAMELEN]; 00120 static int srcix; /* outermost source file index */ 00121 static int optionix; /* option table index */ 00122 static char *src_path = 0; 00123 static int local_scope; /* current local scope index */ 00124 static int host_scope; /* current host scope index */ 00125 static int F90_prod_mif_idx; /* product index */ 00126 static mopd_t *mif_attr_map; /* MIF symbol/func opds for attrs */ 00127 static int *mif_attr_type_map; /* MIF type indices for attrs */ 00128 static int mif_attr_map_size; 00129 static mopd_t *mif_const_map; /* MIF con indices for constants */ 00130 static int mif_const_map_size; 00131 static int *mif_stor_blk_map; /* MIF symbol indices for stor blks */ 00132 static int mif_stor_blk_map_size; 00133 static FILE *MIF_fp = 0; /* File pointer for MIF output */ 00134 static boolean unsigned_type = FALSE; 00135 static int data_value_idx; 00136 static int data_values_consumed = 0; 00137 static long_type do_control_var[16]; 00138 static long_type implied_do_idx[16]; 00139 static int do_control_idx = NONE;/* number of active implied DO's - 1 */ 00140 static int *task_region_stk = 0; 00141 static int task_region_top = -1; 00142 static int task_region_alloc = 0; 00143 static int loop_end_label_idx; 00144 static int parallel_loop_end_label_idx; 00145 static int loop_tregend_blk_idx; 00146 static int loop_tregend_opn_idx; 00147 static int loop_region_idx; 00148 static int processing_aloc = FALSE; 00149 00150 00151 00152 /******************************************************************************\ 00153 |* *| 00154 |* Description: *| 00155 |* This an entry point which is required to be defined when using the MIF *| 00156 |* textual interface. It handles the situation where a MIF routine is unable *| 00157 |* to allocate more memory. Currently, all that is done here is to generate *| 00158 |* an internal error. In the future, it is possible to deallocate some memory*| 00159 |* with this function and then return. *| 00160 |* *| 00161 |* Input parameters: *| 00162 |* Source file being processed, current line number, number of bytes *| 00163 |* attempting to allocate. *| 00164 |* *| 00165 |* Output parameters: *| 00166 |* NONE *| 00167 |* *| 00168 |* Returns: *| 00169 |* NOTHING *| 00170 |* *| 00171 \******************************************************************************/ 00172 void 00173 out_of_memory (char *srcfilename, int lineno, int bytes) { 00174 PRINTMSG(1, 1044, Internal, 0, "mifcvrt.c: out of memory"); 00175 } /* out_of_memory */ 00176 00177 00178 00179 00180 /******************************************************************************\ 00181 |* *| 00182 |* Description: *| 00183 |* This function inserts an initializer into the correct position for an *| 00184 |* object. Initializers from the frontend are not guarenteed to be in *| 00185 |* offset order. *| 00186 |* *| 00187 |* Input parameters: *| 00188 |* Index of init table entry being added, mtag for table that object *| 00189 |* resides in, and index of object. *| 00190 |* *| 00191 |* Output parameters: *| 00192 |* NONE *| 00193 |* *| 00194 |* Returns: *| 00195 |* NOTHING *| 00196 |* *| 00197 \******************************************************************************/ 00198 static 00199 void 00200 insert_init (int initix, mtag_t objtag, int objix) { 00201 /* either a global or local symbol table entry */ 00202 msym_t *obj_entry = objtag==mtag_gsym ? &msp.gsym[objix] : 00203 &msp.lsym[objix]; 00204 int newoffset = msp.init[initix].offset; 00205 00206 TRACE (Func_Entry, "insert_init", NULL); 00207 00208 if (INVALID(obj_entry->init)) { /* no entries yet */ 00209 obj_entry->init = initix; 00210 } 00211 else { 00212 int curr = obj_entry->init; 00213 int prev; /* will be initialized because of above test */ 00214 00215 /* walk through list finding place to insert */ 00216 while (VALID(curr)) { 00217 prev = curr; 00218 curr = msp.init[curr].next; 00219 } 00220 00221 msp.init[prev].next = initix; 00222 msp.init[initix].next = NONE; 00223 } 00224 00225 TRACE (Func_Exit, "insert_init", NULL); 00226 00227 } /* insert_init */ 00228 00229 00230 00231 /******************************************************************************\ 00232 |* *| 00233 |* Description: *| 00234 |* Find the file source position using just the global line number. *| 00235 |* *| 00236 |* Input parameters: *| 00237 |* global_line - the current global line number *| 00238 |* *| 00239 |* Output parameters: *| 00240 |* srcix - the global source index into the MIF src table *| 00241 |* *| 00242 |* Returns: *| 00243 |* NOTHING *| 00244 |* *| 00245 \******************************************************************************/ 00246 static int source_position(int global_line) 00247 { 00248 int act_file_line; 00249 int i; 00250 int j; 00251 int glb_idx; 00252 00253 TRACE (Func_Entry, "source_position", NULL); 00254 00255 # ifdef _DEBUG 00256 if (global_line <= 0) { 00257 PRINTMSG(1, 1044, Internal, 0, "source_position: bad global line"); 00258 } 00259 # endif 00260 00261 GLOBAL_LINE_TO_FILE_LINE(global_line, glb_idx, act_file_line); 00262 00263 /* Determine the source code position of the operation. */ 00264 if (global_line_tbl_idx == 1) { 00265 i = 1; 00266 } 00267 else { 00268 i = 1; 00269 while (GL_GLOBAL_LINE(i) <= global_line) { 00270 i = i + 1; 00271 if (i > global_line_tbl_idx) { 00272 break; 00273 } 00274 } 00275 i = i - 1; 00276 } 00277 00278 srcix = GL_MIF_FILE_ID(i); 00279 00280 # ifdef _DEBUG 00281 if (srcix < 0) { 00282 PRINTMSG(1, 1044, Internal, 0, "source_position: bad srcix"); 00283 } 00284 # endif 00285 00286 return(act_file_line); 00287 00288 TRACE (Func_Exit, "source_position", NULL); 00289 00290 } /* source_position */ 00291 00292 00293 00294 /******************************************************************************\ 00295 |* *| 00296 |* Description: *| 00297 |* This does some initialization, then calls the routines to convert *| 00298 |* the symbol table and and IR to the intermediate form. Then it cleans *| 00299 |* up. *| 00300 |* *| 00301 |* This routine should handle internal program units. (Whichever way *| 00302 |* it's decided). *| 00303 |* *| 00304 |* Input parameters: *| 00305 |* output file stdio pointer *| 00306 |* compiler generation date *| 00307 |* *| 00308 |* Output parameters: *| 00309 |* NONE *| 00310 |* *| 00311 |* Returns: *| 00312 |* NOTHING *| 00313 |* *| 00314 \******************************************************************************/ 00315 void cvrt_to_mif (char *compiler_gen_date) 00316 00317 { 00318 int child_idx; 00319 char msgbuf[512]; 00320 00321 00322 TRACE (Func_Entry, "cvrt_to_mif", NULL); 00323 00324 if (!MIF_fp) { 00325 MIF_fp = mif_open_output(MIF_file, msgbuf); 00326 00327 if (!MIF_fp) { 00328 PRINTMSG(1, 1043, Error, 0, MIF_file); 00329 return; 00330 } 00331 } 00332 00333 /* Emit intermediate text for a program unit. It is called once */ 00334 /* for each BLOCKDATA, PROGRAM, SUBROUTINE, MODULE, external */ 00335 /* SUBROUTINE or external FUNCTION. */ 00336 00337 /* Modules must go thru first, because MODULE PDT's must be first. Clear */ 00338 /* SCP_FIRST_CHILD_IDX for the module, so its children do not get sent */ 00339 /* through. (cvrt_proc_to_mif finds the innermost child and sends it */ 00340 /* first.) After the module is sent through, send all its children via the */ 00341 /* normal order. Then when that's through send the module information */ 00342 /* table. */ 00343 00344 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) { 00345 child_idx = SCP_FIRST_CHILD_IDX(curr_scp_idx); 00346 SCP_FIRST_CHILD_IDX(curr_scp_idx) = NULL_IDX; 00347 00348 cvrt_proc_to_mif(MIF_fp, compiler_gen_date); 00349 00350 if (child_idx != NULL_IDX) { 00351 curr_scp_idx = child_idx; 00352 cvrt_proc_to_mif(MIF_fp, compiler_gen_date); 00353 } 00354 00355 curr_scp_idx = MAIN_SCP_IDX; 00356 00357 /* Cray and MPP go out in a special &%% module because of segldr. */ 00358 00359 # if defined(_TARGET_OS_UNICOS) 00360 write_mod_tbl_file_name(MIF_fp); 00361 # endif 00362 00363 } 00364 else { 00365 cvrt_proc_to_mif(MIF_fp, compiler_gen_date); 00366 } 00367 00368 return; 00369 00370 TRACE (Func_Exit, "cvrt_to_mif", NULL); 00371 00372 } /* cvrt_to_mif */ 00373 00374 00375 00376 /******************************************************************************\ 00377 |* *| 00378 |* Description: *| 00379 |* This does initialization, then converts a subprogram's symbols and IR *| 00380 |* to the intermediate text. Then it cleans up. *| 00381 |* *| 00382 |* Input parameters: *| 00383 |* output file stdio pointer *| 00384 |* compiler generation date *| 00385 |* *| 00386 |* Output parameters: *| 00387 |* NONE *| 00388 |* *| 00389 |* Returns: *| 00390 |* NOTHING *| 00391 |* *| 00392 \******************************************************************************/ 00393 static void cvrt_proc_to_mif (FILE *out_fp, 00394 char *compiler_gen_date) 00395 00396 { 00397 int i, j, k, l; 00398 int pgm_attr_idx; 00399 int pgm_code; 00400 int attr; 00401 int pgm_data; 00402 int save_curr_scp_idx; 00403 char *p; 00404 char *name_ptr; 00405 boolean check_scp = TRUE; 00406 mpos_t pos; 00407 00408 00409 TRACE (Func_Entry, "cvrt_proc_to_mif", NULL); 00410 00411 PROCESS_SIBLING: 00412 00413 /* The innermost children are converted first. The external */ 00414 /* procedure goes out last. */ 00415 00416 if (SCP_FIRST_CHILD_IDX(curr_scp_idx) != NULL_IDX) { 00417 save_curr_scp_idx = curr_scp_idx; 00418 curr_scp_idx = SCP_FIRST_CHILD_IDX(curr_scp_idx); 00419 cvrt_proc_to_mif(out_fp, compiler_gen_date); 00420 curr_scp_idx = save_curr_scp_idx; 00421 } 00422 00423 mif_attr_map_size = attr_tbl_idx + 1; 00424 MEM_ALLOC (mif_attr_map, mopd_t, mif_attr_map_size); 00425 MEM_ALLOC (mif_attr_type_map, int, mif_attr_map_size); 00426 for (i = 0; i < mif_attr_map_size; i++) { 00427 mif_attr_map[i] = mopd_null; 00428 mif_attr_type_map[i] = NONE; 00429 } 00430 00431 mif_const_map_size = const_tbl_idx + 1; 00432 MEM_ALLOC (mif_const_map, mopd_t, mif_const_map_size); 00433 for (i = 0; i < mif_const_map_size; i++) { 00434 mif_const_map[i] = mopd_null; 00435 } 00436 00437 mif_stor_blk_map_size = stor_blk_tbl_idx + 1; 00438 MEM_ALLOC (mif_stor_blk_map, int, mif_stor_blk_map_size); 00439 for (i = 0; i < mif_stor_blk_map_size; i++) { 00440 mif_stor_blk_map[i] = NONE; 00441 } 00442 00443 pgm_attr_idx = SCP_ATTR_IDX(curr_scp_idx); 00444 ATP_SCP_ALIVE(pgm_attr_idx) = TRUE; 00445 00446 /* Subprogram header information */ 00447 init_subprog_info (pgm_attr_idx); 00448 name_ptr = &name_pool[ATP_EXT_NAME_IDX(pgm_attr_idx)].name_char; 00449 msp.name = mnpool(&msp, name_ptr); 00450 00451 /* Allocate scope table entries for this routine. */ 00452 local_scope = mifalloc[mtag_scope](&msp); 00453 00454 host_scope = NONE; 00455 if (SCP_PARENT_IDX(curr_scp_idx) != NULL_IDX) { /* a host exists */ 00456 host_scope = mifalloc[mtag_scope](&msp); 00457 } 00458 else { 00459 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Module) { 00460 host_scope = mifalloc[mtag_scope](&msp); 00461 } 00462 } 00463 00464 /* Construct the type table. */ 00465 msp.immtype = get_basic_type(INTEGER_DEFAULT_TYPE); 00466 00467 # ifdef _HOST32 00468 msp.immtype = get_basic_type(Integer_4); 00469 # endif 00470 00471 /* Construct the symbol table. */ 00472 cvrt_sytb_to_mif(curr_scp_idx); 00473 00474 /* For each and every routine there is a local scope table entry */ 00475 /* and a host scope table entry. Here we make those scope table */ 00476 /* entries point directly to the function table of the local */ 00477 /* and host routines respectively. If a routine does not have a */ 00478 /* host, then the host scope entry for that routine will point to */ 00479 /* itself. */ 00480 attr = SCP_ATTR_IDX(curr_scp_idx); 00481 msp.scope[local_scope].func = mif_attr_map[attr].val; 00482 00483 source_position(SH_GLB_LINE(SCP_FIRST_SH_IDX(curr_scp_idx))); 00484 pos = mpos_null; 00485 pos.line = source_position(SH_GLB_LINE(SCP_FIRST_SH_IDX(curr_scp_idx))); 00486 pos.src = srcix; 00487 msp.scope[local_scope].start = pos; 00488 00489 # if defined(_DEBUG) 00490 00491 if (SCP_SB_HOSTED_STACK_IDX(curr_scp_idx) != NULL_IDX && 00492 SB_LEN_FLD(SCP_SB_HOSTED_STACK_IDX(curr_scp_idx)) != CN_Tbl_Idx) { 00493 PRINTMSG(SB_DEF_LINE(SCP_SB_HOSTED_STACK_IDX(curr_scp_idx)), 1201, 00494 Internal, 00495 SB_DEF_COLUMN(SCP_SB_HOSTED_STACK_IDX(curr_scp_idx)), 00496 SB_NAME_PTR(SCP_SB_HOSTED_STACK_IDX(curr_scp_idx))); 00497 } 00498 00499 # endif 00500 00501 if (SCP_PARENT_IDX(curr_scp_idx) != NULL_IDX) { /* a host exists */ 00502 attr = SCP_ATTR_IDX(SCP_PARENT_IDX(curr_scp_idx)); 00503 00504 if (ATP_PGM_UNIT(attr) == Module) { /* no host - point to itself */ 00505 attr = SCP_ATTR_IDX(curr_scp_idx); 00506 msp.scope[host_scope].func = mif_attr_map[attr].val; 00507 msp.scope[host_scope].start = pos; 00508 msp.scope[host_scope].flags |= mscopeflag_host; 00509 00510 /* JBL - Range issue here. */ 00511 00512 if (SCP_SB_HOSTED_STACK_IDX(curr_scp_idx) != NULL_IDX) { 00513 msp.scope[host_scope].size = 00514 CN_INT_TO_C(SB_LEN_IDX(SCP_SB_HOSTED_STACK_IDX(curr_scp_idx))); 00515 } 00516 else { 00517 msp.scope[host_scope].size = 0; 00518 } 00519 } 00520 else { /* point to the host */ 00521 pos = mpos_null; 00522 pos.line = source_position 00523 (SH_GLB_LINE(SCP_FIRST_SH_IDX(SCP_PARENT_IDX(curr_scp_idx)))); 00524 pos.src = srcix; 00525 msp.scope[host_scope].func = mif_attr_map[attr].val; 00526 msp.scope[host_scope].start = pos; 00527 msp.scope[host_scope].flags |= mscopeflag_host; 00528 00529 /* JBL - Range issue here. */ 00530 00531 if (SCP_SB_HOSTED_STACK_IDX(SCP_PARENT_IDX(curr_scp_idx)) != NULL_IDX){ 00532 msp.scope[host_scope].size = 00533 CN_INT_TO_C(SB_LEN_IDX(SCP_SB_HOSTED_STACK_IDX( 00534 SCP_PARENT_IDX(curr_scp_idx)))); 00535 } 00536 else { 00537 msp.scope[host_scope].size = 0; 00538 } 00539 } 00540 } 00541 else { /* no host - point to itself */ 00542 attr = SCP_ATTR_IDX(curr_scp_idx); 00543 00544 if (ATP_PGM_UNIT(attr) != Module) { 00545 msp.scope[host_scope].func = mif_attr_map[attr].val; 00546 msp.scope[host_scope].start = pos; 00547 msp.scope[host_scope].flags |= mscopeflag_host; 00548 00549 /* JBL - Range issue here. */ 00550 00551 if (SCP_SB_HOSTED_STACK_IDX(curr_scp_idx) != NULL_IDX) { 00552 msp.scope[host_scope].size = 00553 CN_INT_TO_C(SB_LEN_IDX(SCP_SB_HOSTED_STACK_IDX(curr_scp_idx))); 00554 } 00555 else { 00556 msp.scope[host_scope].size = 0; 00557 } 00558 } 00559 } 00560 00561 init_directive(3); 00562 00563 /* Convert the code. */ 00564 cvrt_ir_to_mif(curr_scp_idx); 00565 00566 ATP_SCP_ALIVE(pgm_attr_idx) = FALSE; 00567 00568 /* free the tables */ 00569 00570 if (curr_scp_idx == MAIN_SCP_IDX) { 00571 00572 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Module) { 00573 check_scp = FALSE; /* Tables are gone */ 00574 } 00575 00576 # if !defined(_TARGET_OS_MAX) && !defined(_TARGET_OS_UNICOS) 00577 else { 00578 00579 /* Cray and MPP go out in a special &%% module because of segldr. */ 00580 00581 write_mod_tbl_file_name(out_fp); 00582 } 00583 # endif 00584 } 00585 00586 00587 /* Write the subprogram */ 00588 00589 mifwrite(out_fp, &msp, cmd_line_flags.output_format, "/bin/cat"); 00590 00591 miffree (&msp); 00592 00593 MEM_FREE (mif_attr_map); 00594 MEM_FREE (mif_attr_type_map); 00595 MEM_FREE (mif_const_map); 00596 MEM_FREE (mif_stor_blk_map); 00597 00598 if (check_scp && SCP_SIBLING_IDX(curr_scp_idx) != NULL_IDX) { 00599 curr_scp_idx = SCP_SIBLING_IDX(curr_scp_idx); 00600 goto PROCESS_SIBLING; 00601 } 00602 00603 TRACE (Func_Exit, "cvrt_proc_to_mif", NULL); 00604 00605 } /* cvrt_proc_to_mif */ 00606 00607 00608 00609 /******************************************************************************\ 00610 |* *| 00611 |* Description: *| 00612 |* Convert symbol table to the intermediate form. *| 00613 |* *| 00614 |* Input parameters: *| 00615 |* Subprogram *| 00616 |* Scope index *| 00617 |* *| 00618 |* Output parameters: *| 00619 |* NONE *| 00620 |* *| 00621 |* Returns: *| 00622 |* NOTHING *| 00623 |* *| 00624 \******************************************************************************/ 00625 static void cvrt_sytb_to_mif(int scp_idx) 00626 { 00627 int al_idx; 00628 int attr_idx; 00629 int prev_idx; 00630 int tmp_scp_idx; 00631 int name_idx; 00632 int pgm_idx; 00633 00634 TRACE (Func_Entry, "cvrt_sytb_to_mif", NULL); 00635 00636 /* Claim a function table entry for the main entry right now. */ 00637 pgm_idx = SCP_ATTR_IDX(scp_idx); 00638 mif_attr_map[pgm_idx].tag = mtag_func; 00639 mif_attr_map[pgm_idx].val = mifalloc[mtag_func](&msp); 00640 msp.deffunc = mif_attr_map[pgm_idx].val; 00641 00642 /* 00643 * Claim function table entries for all parent programming units (i.e. 00644 * current subprogram is a nested procedure). This is done because 00645 * dummy args and local stack variables are host associated. 00646 */ 00647 prev_idx = msp.deffunc; 00648 tmp_scp_idx = SCP_PARENT_IDX(scp_idx); 00649 while (tmp_scp_idx != NULL_IDX) { 00650 pgm_idx = SCP_ATTR_IDX(tmp_scp_idx); 00651 mif_attr_map[pgm_idx].tag = mtag_func; 00652 mif_attr_map[pgm_idx].val = mifalloc[mtag_func](&msp); 00653 00654 /* Set up the parent subprogram link. */ 00655 msp.func[prev_idx].within = mif_attr_map[pgm_idx].val; 00656 prev_idx = mif_attr_map[pgm_idx].val; 00657 tmp_scp_idx = SCP_PARENT_IDX(tmp_scp_idx); 00658 } 00659 00660 /* Sends main entry point, alternate entry points, function */ 00661 /* results, all dummy arguments, and any accessed derived types. */ 00662 00663 cvrt_proc(SCP_ATTR_IDX(scp_idx), SCP_ENTRY_IDX(scp_idx), Definition); 00664 00665 for (name_idx = SCP_LN_FW_IDX(scp_idx) + 1; 00666 name_idx < SCP_LN_LW_IDX(scp_idx); 00667 name_idx++) { 00668 attr_idx = LN_ATTR_IDX(name_idx); 00669 cvrt_attr_ntry(attr_idx); 00670 } 00671 00672 al_idx = SCP_ATTR_LIST(curr_scp_idx); 00673 while (al_idx != NULL_IDX) { 00674 if (AT_OBJ_CLASS(AL_ATTR_IDX(al_idx)) == Data_Obj && 00675 ATD_CLASS(AL_ATTR_IDX(al_idx)) == Compiler_Tmp && 00676 AT_REFERENCED(AL_ATTR_IDX(al_idx)) == Not_Referenced) { 00677 00678 /* intentionally blank. Don't send unreferenced tmps through */ 00679 } 00680 else if (mif_attr_map [AL_ATTR_IDX(al_idx)].tag == mtag_none) { 00681 cvrt_attr_ntry(AL_ATTR_IDX(al_idx)); 00682 } 00683 00684 al_idx = AL_NEXT_IDX(al_idx); 00685 } 00686 00687 /* Send all parent procedures */ 00688 tmp_scp_idx = SCP_PARENT_IDX(scp_idx); 00689 while (tmp_scp_idx != NULL_IDX) { 00690 cvrt_proc(SCP_ATTR_IDX(tmp_scp_idx), 00691 SCP_ENTRY_IDX(tmp_scp_idx), 00692 Parent); 00693 tmp_scp_idx = SCP_PARENT_IDX(tmp_scp_idx); 00694 } 00695 00696 TRACE (Func_Exit, "cvrt_sytb_to_mif", NULL); 00697 00698 } /* cvrt_sytb_to_mif */ 00699 00700 00701 00702 /******************************************************************************\ 00703 |* *| 00704 |* Description: *| 00705 |* Add a list of tasking symbols to MIF. *| 00706 |* *| 00707 |* Input parameters: *| 00708 |* list_idx - index into frontend's IL table which references the list *| 00709 |* of symbols. *| 00710 |* default_usage - default tasking symbol usage of symbol. *| 00711 |* dope_is_value - flag if dope symbols should be treated as value usage *| 00712 |* *| 00713 |* Output parameters: *| 00714 |* t - tasking region which symbols are to be added to. *| 00715 |* *| 00716 |* Returns: *| 00717 |* NOTHING *| 00718 |* *| 00719 \******************************************************************************/ 00720 static void add_tasking_symbols(mtaskreg_t *t, 00721 int list_idx, 00722 mtaskusage_t default_usage, 00723 boolean dope_is_value) 00724 { 00725 int sublist_idx; 00726 int symix; 00727 mtasksym_t *s; 00728 mtasksym_t *l; 00729 00730 TRACE (Func_Entry, "add_tasking_symbols", NULL); 00731 00732 /* Process list of variables */ 00733 if (IL_FLD(list_idx) == IL_Tbl_Idx) { 00734 sublist_idx = IL_IDX(list_idx); 00735 while (sublist_idx) { 00736 symix = mifalloc[mtag_tasksym](&msp); 00737 s = msp.tasksym + symix; 00738 00739 /* Add symbol to tail of list */ 00740 l = msp.tasksym + t->tasksym; 00741 if (VALID(t->tasksym)) { 00742 while (VALID(l->next)) { 00743 l = msp.tasksym + l->next; 00744 } 00745 l->next = symix; 00746 } 00747 else { 00748 t->tasksym = symix; 00749 } 00750 00751 if (dope_is_value && 00752 AT_OBJ_CLASS(IL_IDX(sublist_idx)) == Data_Obj && 00753 (ATD_IM_A_DOPE(IL_IDX(sublist_idx)) || 00754 (TYP_TYPE(ATD_TYPE_IDX(IL_IDX(sublist_idx))) == Structure && 00755 ATT_POINTER_CPNT(TYP_IDX(ATD_TYPE_IDX( 00756 IL_IDX(sublist_idx))))))) { 00757 /* must be VALUE not PRIVATE for dope vectors */ 00758 s->taskusage = mtaskusage_value; 00759 } 00760 else { 00761 s->taskusage = default_usage; 00762 } 00763 s->sym = mif_attr_map[IL_IDX(sublist_idx)]; 00764 00765 sublist_idx = IL_NEXT_LIST_IDX(sublist_idx); 00766 } 00767 } 00768 00769 TRACE (Func_Exit, "cvrt_sytb_to_mif", NULL); 00770 00771 } /* add_tasking_symbols */ 00772 00773 00774 00775 /******************************************************************************\ 00776 |* *| 00777 |* Description: *| 00778 |* Map frontend work distribution to MIF distribution. *| 00779 |* *| 00780 |* Input parameters: *| 00781 |* val - frontend work distribution value *| 00782 |* *| 00783 |* Output parameters: *| 00784 |* NONE *| 00785 |* *| 00786 |* Returns: *| 00787 |* MIF work distibution value *| 00788 |* *| 00789 \******************************************************************************/ 00790 static mworkdist_t map_work_distribution(int val) 00791 { 00792 switch (val) { 00793 case CMIC_WORK_DIST_SINGLE: 00794 return mworkdist_single; 00795 00796 case CMIC_WORK_DIST_VECTOR: 00797 return mworkdist_vector; 00798 00799 case CMIC_WORK_DIST_GUIDED: 00800 return mworkdist_guided; 00801 00802 case CMIC_WORK_DIST_NUMCHUNKS: 00803 return mworkdist_numchunks; 00804 00805 case CMIC_WORK_DIST_CHUNKSIZE: 00806 return mworkdist_chunksize; 00807 00808 case CMIC_WORK_DIST_NCPUS_CHUNKS: 00809 return mworkdist_ncpus_chunks; 00810 00811 default: 00812 PRINTMSG(1, 1044, Internal, 0, 00813 "map_work_distribution: unexpected work distribution"); 00814 } 00815 00816 } /* map_work_distribution */ 00817 00818 00819 00820 /******************************************************************************\ 00821 |* *| 00822 |* Description: *| 00823 |* Start a new tasking region. *| 00824 |* *| 00825 |* Input parameters: *| 00826 |* ir_idx - frontend ir index for tasking region *| 00827 |* *| 00828 |* Output parameters: *| 00829 |* NONE *| 00830 |* *| 00831 |* Returns: *| 00832 |* MIF taskreg index *| 00833 |* *| 00834 \******************************************************************************/ 00835 static int start_task_region(mblk_t *blk, 00836 int ir_idx, 00837 mopnflag_t flags, 00838 mpos_t pos) 00839 { 00840 int tskix = mifalloc[mtag_taskreg](&msp); 00841 mtaskreg_t *t = msp.taskreg + tskix; 00842 int list_idx; 00843 int symix; 00844 mtasksym_t *s; 00845 mopd_t opd0; 00846 mtype_t typ; 00847 mtasksym_t *l; 00848 00849 TRACE (Func_Entry, "start_task_region", NULL); 00850 00851 if (IR_OPR(ir_idx)==Case_Cmic_Opr && 00852 msp.taskreg[task_region_stk[task_region_top]].regionclass== 00853 mregionclass_case) { 00854 /* end previous case region and reuse task region stack entry */ 00855 opd0.tag = mtag_taskreg; 00856 opd0.val = task_region_stk[task_region_top]; 00857 mif_opn_add(blk, 00858 mop_tregend, 00859 get_basic_type(NONE), 00860 pos, 00861 flags, 00862 opd0, 00863 mopd_null, 00864 mopd_null); 00865 } 00866 else { 00867 /* See if there is enough room in the tasking region stack */ 00868 if (++task_region_top >= task_region_alloc) { 00869 task_region_alloc += 5; 00870 MEM_REALLOC(task_region_stk, int, task_region_alloc); 00871 } 00872 } 00873 00874 /* Stack tasking region */ 00875 task_region_stk[task_region_top] = tskix; 00876 00877 /* Do region specific setting */ 00878 switch (IR_OPR(ir_idx)) { 00879 case Case_Cmic_Opr: 00880 t->regionclass = mregionclass_case; 00881 t->within = task_region_stk[task_region_top-1]; 00882 break; 00883 00884 case Guard_Cmic_Opr: 00885 t->regionclass = mregionclass_guard; 00886 00887 /* Add temp if numbered guard */ 00888 if (IR_FLD_L(ir_idx) != NO_Tbl_Idx) { 00889 t->guardtemp = cvrt_attr_ntry(IR_IDX_L(ir_idx)); 00890 } 00891 break; 00892 00893 case Doall_Cmic_Opr: 00894 t->regionclass = mregionclass_doall; 00895 00896 /* Process if temp (list element 0) */ 00897 list_idx = IR_IDX_L(ir_idx); 00898 if (IL_FLD(list_idx) != NO_Tbl_Idx) { 00899 t->iftemp = cvrt_attr_ntry(IL_IDX(list_idx)); 00900 } 00901 00902 /* Process SHARED variables (list element 1) */ 00903 list_idx = IL_NEXT_LIST_IDX(list_idx); 00904 add_tasking_symbols(t, list_idx, mtaskusage_shared, FALSE); 00905 00906 /* Process PRIVATE variables (list element 2) */ 00907 list_idx = IL_NEXT_LIST_IDX(list_idx); 00908 add_tasking_symbols(t, list_idx, mtaskusage_private, TRUE); 00909 00910 /* See if AUTOSCOPING was specified (list element 3) */ 00911 list_idx = IL_NEXT_LIST_IDX(list_idx); 00912 if (IL_FLD(list_idx) == CN_Tbl_Idx) { 00913 t->flags |= mtaskregflag_defaultusage; 00914 } 00915 00916 /* Process CONTROL variables (list element 4) */ 00917 list_idx = IL_NEXT_LIST_IDX(list_idx); 00918 /* BECKER - MIF does not have context usage, but PDGCS currently 00919 * treats it the same as context iterate. 00920 */ 00921 add_tasking_symbols(t, list_idx, mtaskusage_iterate, FALSE); 00922 00923 /* See if SAVELAST was specified (list element 5) */ 00924 list_idx = IL_NEXT_LIST_IDX(list_idx); 00925 if (IL_FLD(list_idx) == CN_Tbl_Idx) { 00926 t->flags |= mtaskregflag_savelast; 00927 } 00928 00929 /* Process maxcpus temp (list element 6) */ 00930 list_idx = IL_NEXT_LIST_IDX(list_idx); 00931 if (IL_FLD(list_idx) != NO_Tbl_Idx) { 00932 t->maxcpustemp = cvrt_attr_ntry(IL_IDX(list_idx)); 00933 } 00934 00935 /* Process work distribution class (list element 7) */ 00936 list_idx = IL_NEXT_LIST_IDX(list_idx); 00937 t->workdist = map_work_distribution(CN_INT_TO_C(IL_IDX(list_idx))); 00938 00939 /* Process work distribution temp (list element 8) */ 00940 list_idx = IL_NEXT_LIST_IDX(list_idx); 00941 if (IL_FLD(list_idx) != NO_Tbl_Idx) { 00942 t->disttemp = cvrt_attr_ntry(IL_IDX(list_idx)); 00943 } 00944 00945 /* Process loop control variable */ 00946 symix = mifalloc[mtag_tasksym](&msp); 00947 s = msp.tasksym + symix; 00948 00949 /* Add symbol to tail of list */ 00950 l = msp.tasksym + t->tasksym; 00951 if (VALID(t->tasksym)) { 00952 while (VALID(l->next)) { 00953 l = msp.tasksym + l->next; 00954 } 00955 l->next = symix; 00956 } 00957 else { 00958 t->tasksym = symix; 00959 } 00960 00961 s->taskusage = mtaskusage_induction; 00962 s->sym = mif_attr_map[IR_IDX_R(ir_idx)]; 00963 00964 /* BECKER - Hack code to be removed once frontend 00965 * clearly marks the end of a parallel loop. 00966 * 00967 * Preserve label index which ends parallel loop. 00968 */ 00969 parallel_loop_end_label_idx = loop_end_label_idx; 00970 break; 00971 00972 case Doparallel_Cmic_Opr: 00973 t->regionclass = mregionclass_loop; 00974 t->within = task_region_stk[task_region_top-1]; 00975 00976 /* Process work distribution class (list element 0) */ 00977 list_idx = IR_IDX_L(ir_idx); 00978 t->workdist = map_work_distribution(CN_INT_TO_C(IL_IDX(list_idx))); 00979 00980 /* Process work distribution temp (list element 1) */ 00981 list_idx = IL_NEXT_LIST_IDX(list_idx); 00982 if (IL_FLD(list_idx) != NO_Tbl_Idx) { 00983 t->disttemp = cvrt_attr_ntry(IL_IDX(list_idx)); 00984 } 00985 00986 /* Process loop control variable */ 00987 symix = mifalloc[mtag_tasksym](&msp); 00988 s = msp.tasksym + symix; 00989 t->tasksym = symix; 00990 s->taskusage = mtaskusage_induction; 00991 s->sym = mif_attr_map[IR_IDX_R(ir_idx)]; 00992 00993 /* BECKER - Hack code to be removed once frontend 00994 * clearly marks the end of a parallel loop. 00995 * 00996 * Preserve label index which ends parallel loop. 00997 */ 00998 parallel_loop_end_label_idx = loop_end_label_idx; 00999 break; 01000 01001 case Parallel_Cmic_Opr: 01002 t->regionclass = mregionclass_parallel; 01003 01004 /* Process if temp (list element 0) */ 01005 list_idx = IR_IDX_L(ir_idx); 01006 if (IL_FLD(list_idx) != NO_Tbl_Idx) { 01007 t->iftemp = cvrt_attr_ntry(IL_IDX(list_idx)); 01008 } 01009 01010 /* Process SHARED variables (list element 1) */ 01011 list_idx = IL_NEXT_LIST_IDX(list_idx); 01012 add_tasking_symbols(t, list_idx, mtaskusage_shared, FALSE); 01013 01014 /* Process PRIVATE variables (list element 2) */ 01015 list_idx = IL_NEXT_LIST_IDX(list_idx); 01016 add_tasking_symbols(t, list_idx, mtaskusage_private, TRUE); 01017 01018 /* See if AUTOSCOPING was specified (list element 3) */ 01019 list_idx = IL_NEXT_LIST_IDX(list_idx); 01020 if (IL_FLD(list_idx) == CN_Tbl_Idx) { 01021 t->flags |= mtaskregflag_defaultusage; 01022 } 01023 01024 /* Process CONTROL variables (list element 4) */ 01025 list_idx = IL_NEXT_LIST_IDX(list_idx); 01026 /* BECKER - MIF does not have context usage, but PDGCS currently 01027 * treats it the same as context iterate. 01028 */ 01029 add_tasking_symbols(t, list_idx, mtaskusage_iterate, FALSE); 01030 01031 /* Process maxcpus temp (list element 5) */ 01032 list_idx = IL_NEXT_LIST_IDX(list_idx); 01033 if (IL_FLD(list_idx) != NO_Tbl_Idx) { 01034 t->maxcpustemp = cvrt_attr_ntry(IL_IDX(list_idx)); 01035 } 01036 break; 01037 01038 default: 01039 PRINTMSG(1, 1044, Internal, 0, 01040 "start_task_region: unexpected OPR"); 01041 break; 01042 } 01043 01044 TRACE (Func_Exit, "start_task_region", NULL); 01045 01046 return tskix; 01047 01048 } /* start_task_region */ 01049 01050 01051 01052 /******************************************************************************\ 01053 |* *| 01054 |* Description: *| 01055 |* Convert an expression to the intermediate form. *| 01056 |* *| 01057 |* Input parameters: *| 01058 |* NONE *| 01059 |* *| 01060 |* Output parameters: *| 01061 |* NONE *| 01062 |* *| 01063 |* Returns: *| 01064 |* NOTHING *| 01065 |* *| 01066 \******************************************************************************/ 01067 static void cvrt_exp_to_mif(mopd_t *result, 01068 mblk_t *blk, 01069 int ir_idx, 01070 fld_type field, 01071 mopnflag_t flags, 01072 enum evcontext context) 01073 { 01074 01075 int attr_idx; 01076 int base_attr; 01077 boolean bound_chk; 01078 int next_idx; 01079 int temp_ir_idx; 01080 long_type i,j; 01081 int unused1; 01082 int unused2; 01083 int basic; 01084 int opnix; 01085 int tskix; 01086 mopd_t opd, opd0, opd1, opd2; 01087 int typeix; 01088 mop_t op; 01089 mtype_t type; 01090 mpos_t pos = mpos_null; 01091 mopn_t *o; 01092 mopnflag_t save_flags; 01093 01094 01095 TRACE (Func_Entry, "cvrt_exp_to_mif", NULL); 01096 01097 *result = mopd_null; 01098 01099 01100 switch (field) { 01101 01102 case NO_Tbl_Idx : 01103 break; 01104 01105 01106 case CN_Tbl_Idx : 01107 01108 if (ir_idx >= mif_const_map_size || 01109 (mif_const_map[ir_idx].tag == mtag_none)) { 01110 /* Constant not seen before. Convert and add to mapping table. */ 01111 01112 cvrt_const((char *)&CN_CONST(ir_idx), 01113 CN_TYPE_IDX(ir_idx), 01114 CN_TYPE_IDX(ir_idx), 01115 result); 01116 01117 if (ir_idx < mif_const_map_size) { 01118 mif_const_map[ir_idx] = *result; 01119 } 01120 } 01121 else { 01122 /* Constant was seen before, get converted constant from mapping table. */ 01123 *result = mif_const_map[ir_idx]; 01124 } 01125 01126 break; 01127 01128 01129 case IL_Tbl_Idx : 01130 01131 /* Convert the list into a chain of list pseudo-operations. */ 01132 for (; ir_idx != NULL_IDX; ir_idx = IL_NEXT_LIST_IDX(ir_idx)) { 01133 if (IL_IDX(ir_idx) != NULL_IDX) { 01134 cvrt_exp_to_mif(&opd0, 01135 blk, 01136 IL_IDX(ir_idx), 01137 IL_FLD(ir_idx), 01138 flags, 01139 context); 01140 } 01141 else { 01142 opd0 = mopd_null; 01143 } 01144 01145 *result = mif_opn_add(blk, 01146 mop_list, 01147 mopdtype(&msp, opd0, blk->opn), 01148 mpos_null, 01149 0, 01150 opd0, 01151 *result, 01152 mopd_null); 01153 } 01154 break; 01155 01156 01157 case AT_Tbl_Idx : 01158 01159 if (AT_OBJ_CLASS(ir_idx) == Data_Obj) { 01160 if (ATD_CLASS(ir_idx) == Compiler_Tmp && 01161 ATD_TMP_INIT_NOT_DONE(ir_idx)) { 01162 insert_init_stmt_for_tmp(ir_idx); 01163 } 01164 01165 if (context == address) { 01166 *result = mif_opn_add(blk, 01167 mop_loc, 01168 get_ptr_type(AT_Tbl_Idx, ir_idx), 01169 mpos_null, 01170 0, 01171 mif_attr_map[ir_idx], 01172 mopd_null, 01173 mopd_null); 01174 } 01175 else { 01176 *result = mif_attr_map[ir_idx]; 01177 } 01178 } 01179 else if (AT_OBJ_CLASS(ir_idx) == Pgm_Unit) { 01180 if ((ATP_PROC(ir_idx) == Extern_Proc) && 01181 (AT_ACTUAL_ARG(ir_idx)) && 01182 (ATP_DCL_EXTERNAL(ir_idx))) { 01183 *result = mif_opn_add(blk, 01184 mop_loc, 01185 get_ptr_type(AT_Tbl_Idx, ir_idx), 01186 pos, 01187 0, 01188 mif_attr_map[ir_idx], 01189 mopd_null, 01190 mopd_null); 01191 } 01192 else { 01193 *result = mif_attr_map[ir_idx]; 01194 } 01195 } 01196 break; 01197 01198 01199 case IR_Tbl_Idx : 01200 01201 01202 # ifdef _DEBUG 01203 if (IR_TYPE_IDX(ir_idx) == NULL_IDX) { 01204 PRINTMSG(IR_LINE_NUM(ir_idx), 01205 993, 01206 Internal, 01207 IR_COL_NUM(ir_idx)); 01208 } 01209 # endif 01210 01211 basic = get_basic_type(IR_TYPE_IDX(ir_idx)); 01212 01213 /* Set flag which controls array syntax expansion in tmod. */ 01214 if (IR_RANK(ir_idx)) { 01215 flags |= mopnflag_array; 01216 } 01217 else { 01218 flags &= ~mopnflag_array; 01219 } 01220 01221 /* Determine the source code position of the operation. */ 01222 pos = mpos_null; 01223 pos.line = source_position(IR_LINE_NUM(ir_idx)); 01224 pos.src = srcix; 01225 pos.col = IR_COL_NUM(ir_idx); 01226 01227 switch (IR_OPR(ir_idx)) { 01228 01229 /* Niladic intrinsics */ 01230 case Ranf_Opr : 01231 *result = mif_opn_add(blk, mop_ranf, basic, pos, 01232 flags | mopnflag_precious | 01233 mopnflag_immobile | 01234 mopnflag_runtime | 01235 mopnflag_variant | 01236 mopnflag_distinct, 01237 mopd_null, mopd_null, mopd_null); 01238 break; 01239 01240 case Rtc_Opr : 01241 *result = mif_opn_add(blk, mop_clock, basic, pos, 01242 flags | mopnflag_immobile | 01243 mopnflag_runtime | 01244 mopnflag_variant | 01245 mopnflag_distinct, 01246 mopd_null, mopd_null, mopd_null); 01247 break; 01248 01249 case Numarg_Opr : 01250 *result = mif_opn_add(blk, mop_numargs, basic, pos, 01251 flags, mopd_null, mopd_null, mopd_null); 01252 break; 01253 01254 case My_Pe_Opr : 01255 break; 01256 01257 case Argchck_Present_Opr : 01258 *result = mif_opn_add(blk, mop_argchk, basic, pos, 01259 flags, mopd_null, mopd_null, mopd_null); 01260 break; 01261 01262 case Argchck_Loc_Opr : 01263 *result = mif_opn_add(blk, mop_argckloc, basic, pos, 01264 flags, mopd_null, mopd_null, mopd_null); 01265 break; 01266 01267 case Readsm_Opr : 01268 opd0 = mopd_0; 01269 opd0.val = _semget_op; 01270 *result = mif_opn_add(blk, mop_asm, basic, pos, 01271 flags, opd0, mopd_null, mopd_null); 01272 break; 01273 01274 case Remote_Write_Barrier_Opr : 01275 opd0 = mopd_0; 01276 opd0.val = _remote_write_barrier_op; 01277 *result = mif_opn_add(blk, mop_asm, basic, pos, 01278 flags, opd0, mopd_null, mopd_null); 01279 break; 01280 01281 case Memory_Barrier_Opr : 01282 opd0 = mopd_0; 01283 opd0.val = _memory_barrier_op; 01284 *result = mif_opn_add(blk, mop_asm, basic, pos, 01285 flags, opd0, mopd_null, mopd_null); 01286 break; 01287 01288 case Write_Memory_Barrier_Opr : 01289 opd0 = mopd_0; 01290 opd0.val = _write_memory_barrier_op; 01291 *result = mif_opn_add(blk, mop_asm, basic, pos, 01292 flags, opd0, mopd_null, mopd_null); 01293 break; 01294 01295 case Mul_Opr : 01296 *result = mif_opn_add(blk, mop_bmul, basic, pos, 01297 flags, mopd_null, mopd_null, mopd_null); 01298 break; 01299 01300 case Mcbl_Opr : 01301 *result = mif_opn_add(blk, mop_bmclr, basic, pos, 01302 flags, mopd_null, mopd_null, mopd_null); 01303 break; 01304 01305 case Get_Ieee_Exceptions_Opr : 01306 *result = mif_opn_add(blk, mop_get_all_estat, basic, pos, 01307 flags, mopd_null, mopd_null, mopd_null); 01308 break; 01309 01310 case Get_Ieee_Interrupts_Opr : 01311 *result = mif_opn_add(blk, mop_get_interupt, basic, pos, 01312 flags, mopd_null, mopd_null, mopd_null); 01313 break; 01314 01315 case Get_Ieee_Rounding_Mode_Opr : 01316 *result = mif_opn_add(blk, mop_getround, basic, pos, 01317 flags, mopd_null, mopd_null, mopd_null); 01318 break; 01319 01320 case Endcase_Cmic_Opr: 01321 case Endguard_Cmic_Opr: 01322 case Enddo_Cmic_Opr: 01323 case Endparallel_Cmic_Opr: 01324 /* Additional flag setting */ 01325 switch (IR_OPR(ir_idx)) { 01326 case Enddo_Cmic_Opr: 01327 01328 /* BECKER - Hack code to be removed once frontend 01329 * clearly marks the end of a parallel loop. 01330 * 01331 * Remove tregend generated at end of loop. 01332 * Assume last visited region was a task loop. 01333 */ 01334 msp.blk[loop_tregend_blk_idx].opn[loop_tregend_opn_idx] = mopn_null; 01335 task_region_top++; 01336 task_region_stk[task_region_top] = loop_region_idx; 01337 01338 msp.taskreg[task_region_stk[task_region_top]].flags |= 01339 mtaskregflag_extendloop; 01340 break; 01341 01342 case Endcase_Cmic_Opr: 01343 msp.taskreg[task_region_stk[task_region_top]].flags |= 01344 mtaskregflag_lastcase; 01345 break; 01346 } 01347 01348 opd0.tag = mtag_taskreg; 01349 opd0.val = task_region_stk[task_region_top--]; 01350 *result = mif_opn_add(blk, 01351 mop_tregend, 01352 get_basic_type(NONE), 01353 pos, 01354 flags, 01355 opd0, 01356 mopd_null, 01357 mopd_null); 01358 break; 01359 01360 01361 /* Monadic intrinsics */ 01362 case Int_Mult_Upper_Opr : 01363 case Get_Ieee_Status_Opr : 01364 case Numcpus_Cmic_Opr : 01365 case Mmx_Opr : 01366 case Mld_Opr : 01367 case Uplus_Opr : 01368 case Uminus_Opr : 01369 case Paren_Opr : 01370 case Present_Opr : 01371 case Abs_Opr : 01372 case Cos_Opr : 01373 case Sin_Opr : 01374 case Tan_Opr : 01375 case Acos_Opr : 01376 case Asin_Opr : 01377 case Atan_Opr : 01378 case Cot_Opr : 01379 case Exp_Opr : 01380 case Sqrt_Opr : 01381 case Cosh_Opr : 01382 case Sinh_Opr : 01383 case Tanh_Opr : 01384 case Log_10_Opr : 01385 case Log_E_Opr : 01386 case Conjg_Opr : 01387 case Dble_Opr : 01388 case Int_Opr : 01389 case Logical_Opr : 01390 case Real_Opr : 01391 case Ichar_Opr : 01392 case Char_Opr : 01393 case Cvrt_Opr : 01394 case Cvrt_Unsigned_Opr : 01395 case Leadz_Opr : 01396 case Poppar_Opr : 01397 case Popcnt_Opr : 01398 case Not_Opr : 01399 case Bnot_Opr : 01400 case Nint_Opr : 01401 case Anint_Opr : 01402 case Aint_Opr : 01403 case Aimag_Opr : 01404 case Clen_Opr : 01405 case Len_Trim_Opr : 01406 case Adjustl_Opr : 01407 case Adjustr_Opr : 01408 case Ceiling_Opr : 01409 case Floor_Opr : 01410 case Exponent_Opr : 01411 case Fraction_Opr : 01412 case Unit_Opr : 01413 case Getpos_Opr : 01414 case Length_Opr : 01415 case Transpose_Opr: 01416 case Mask_Opr : 01417 case Ranget_Opr : 01418 case Ranset_Opr : 01419 case Set_Ieee_Status_Opr : 01420 case Set_Ieee_Exceptions_Opr : 01421 case Set_Ieee_Interrupts_Opr : 01422 case Set_Ieee_Rounding_Mode_Opr : 01423 case Test_Ieee_Interrupt_Opr : 01424 case Test_Ieee_Exception_Opr : 01425 case Enable_Ieee_Interrupt_Opr : 01426 case Disable_Ieee_Interrupt_Opr : 01427 case Ieee_Finite_Opr : 01428 case Ieee_Is_Nan_Opr : 01429 case Ieee_Class_Opr : 01430 01431 opd0 = mopd_null; 01432 opd1 = mopd_null; 01433 opd2 = mopd_null; 01434 01435 cvrt_exp_to_mif(&opd0, 01436 blk, 01437 IR_IDX_L(ir_idx), 01438 IR_FLD_L(ir_idx), 01439 flags, 01440 value); 01441 01442 switch (IR_OPR(ir_idx)) { 01443 case Int_Mult_Upper_Opr: 01444 opd1 = opd0; 01445 opd0 = mopd_0; 01446 opd0.val = _int_mult_upper_op; 01447 op = mop_asm; 01448 break; 01449 case Numcpus_Cmic_Opr : 01450 op = mop_set_numcpus; 01451 break; 01452 case Mmx_Opr : 01453 op = mop_bmmx; 01454 break; 01455 case Mld_Opr : 01456 op = mop_bmld; 01457 break; 01458 case Uplus_Opr : 01459 op = mop_xmit; 01460 break; 01461 case Paren_Opr : 01462 op = mop_paren; 01463 break; 01464 case Present_Opr : 01465 op = mop_present; 01466 break; 01467 case Uminus_Opr : 01468 op = mop_neg; 01469 break; 01470 case Abs_Opr : 01471 if (msp.type[mopdtype(&msp, opd0, blk->opn)].u.class == 01472 mtypeclass_complex) { 01473 op = mop_cabs; 01474 } 01475 else { 01476 op = mop_abs; 01477 } 01478 break; 01479 case Cos_Opr : 01480 op = mop_cos; 01481 break; 01482 case Sin_Opr : 01483 op = mop_sin; 01484 break; 01485 case Tan_Opr : 01486 op = mop_tan; 01487 break; 01488 case Acos_Opr : 01489 op = mop_acos; 01490 break; 01491 case Asin_Opr : 01492 op = mop_asin; 01493 break; 01494 case Atan_Opr : 01495 op = mop_atan; 01496 break; 01497 case Cot_Opr : 01498 op = mop_cot; 01499 break; 01500 case Exp_Opr : 01501 op = mop_exp; 01502 break; 01503 case Sqrt_Opr : 01504 op = mop_sqrt; 01505 break; 01506 case Cosh_Opr : 01507 op = mop_cosh; 01508 break; 01509 case Sinh_Opr : 01510 op = mop_sinh; 01511 break; 01512 case Tanh_Opr : 01513 op = mop_tanh; 01514 break; 01515 case Log_10_Opr : 01516 op = mop_log10; 01517 break; 01518 case Log_E_Opr : 01519 op = mop_log; 01520 break; 01521 case Conjg_Opr : 01522 op = mop_conjg; 01523 break; 01524 case Dble_Opr : 01525 case Int_Opr : 01526 case Logical_Opr : 01527 case Real_Opr : 01528 case Ichar_Opr : 01529 case Char_Opr : 01530 case Cvrt_Opr : 01531 op = mop_cast; 01532 break; 01533 case Cvrt_Unsigned_Opr : 01534 unsigned_type = TRUE; 01535 basic = get_basic_type(IR_TYPE_IDX(ir_idx)); 01536 unsigned_type = FALSE; 01537 op = mop_cast; 01538 break; 01539 case Leadz_Opr : 01540 op = mop_lead0; 01541 break; 01542 case Poppar_Opr : 01543 op = mop_parity; 01544 break; 01545 case Popcnt_Opr : 01546 op = mop_pop; 01547 break; 01548 case Not_Opr : 01549 op = mop_not; 01550 break; 01551 case Bnot_Opr : 01552 op = mop_not; 01553 break; 01554 case Nint_Opr : 01555 case Anint_Opr : 01556 op = mop_round; 01557 break; 01558 case Aint_Opr : 01559 op = mop_trunc; 01560 break; 01561 case Aimag_Opr : 01562 op = mop_cast; 01563 opd2 = mopd_1; /* select imaginary part */ 01564 break; 01565 case Clen_Opr : 01566 op = mop_chlen; 01567 break; 01568 case Len_Trim_Opr : 01569 op = mop_chlentr; 01570 break; 01571 case Adjustl_Opr : 01572 op = mop_chadjl; 01573 break; 01574 case Adjustr_Opr : 01575 op = mop_chadjr; 01576 break; 01577 case Unit_Opr : 01578 op = mop_unit; 01579 break; 01580 case Getpos_Opr : 01581 op = mop_getpos; 01582 break; 01583 case Length_Opr : 01584 op = mop_length; 01585 break; 01586 case Ceiling_Opr : 01587 op = mop_ceiling; 01588 break; 01589 case Floor_Opr : 01590 op = mop_floor; 01591 break; 01592 case Exponent_Opr : 01593 op = mop_getexpo; 01594 break; 01595 case Fraction_Opr : 01596 op = mop_fract; 01597 break; 01598 case Transpose_Opr: 01599 op = mop_transp; 01600 break; 01601 case Mask_Opr : 01602 op = mop_mask; 01603 break; 01604 case Ranget_Opr : 01605 op = mop_ranget; 01606 break; 01607 case Ranset_Opr : 01608 op = mop_ranset; 01609 break; 01610 case Set_Ieee_Status_Opr : 01611 op = mop_set_stat; 01612 break; 01613 case Get_Ieee_Status_Opr : 01614 opd1 = opd0; 01615 opd0 = mopd_0; 01616 opd0.val = _readSR_op; 01617 op = mop_asm; 01618 break; 01619 01620 case Set_Ieee_Exceptions_Opr : 01621 op = mop_set_all_estat; 01622 break; 01623 case Set_Ieee_Interrupts_Opr : 01624 op = mop_set_interupt; 01625 break; 01626 case Set_Ieee_Rounding_Mode_Opr : 01627 op = mop_setround; 01628 break; 01629 case Test_Ieee_Interrupt_Opr : 01630 op = mop_tst_interupt; 01631 break; 01632 case Test_Ieee_Exception_Opr : 01633 op = mop_tst_estat; 01634 break; 01635 case Enable_Ieee_Interrupt_Opr : 01636 op = mop_enbl_interupt; 01637 break; 01638 case Disable_Ieee_Interrupt_Opr : 01639 op = mop_dsbl_interupt; 01640 break; 01641 case Ieee_Finite_Opr : 01642 op = mop_isfinite; 01643 break; 01644 case Ieee_Is_Nan_Opr : 01645 op = mop_isnan; 01646 break; 01647 case Ieee_Class_Opr : 01648 op = mop_fpclass; 01649 break; 01650 } 01651 01652 *result = mif_opn_add(blk, 01653 op, 01654 basic, 01655 pos, 01656 flags, 01657 opd0, 01658 opd1, 01659 opd2); 01660 break; 01661 01662 01663 /* Dyadic intrinsics */ 01664 case Set_Ieee_Exception_Opr : 01665 case Clear_Ieee_Exception_Opr : 01666 case Spacing_Opr : 01667 case Rrspacing_Opr : 01668 case I24mult_Opr : 01669 case Mldmx_Opr : 01670 case All_Opr: 01671 case Any_Opr: 01672 case Count_Opr: 01673 case Atan2_Opr : 01674 case Cmplx_Opr : 01675 case Dim_Opr : 01676 case Mod_Opr : 01677 case Modulo_Opr : 01678 case Sign_Opr : 01679 case Scale_Opr : 01680 case Set_Exponent_Opr : 01681 case Dprod_Opr : 01682 case Fcd_Opr : 01683 case Shiftl_Opr : 01684 case Shiftr_Opr : 01685 case Shifta_Opr : 01686 case Shift_Opr : 01687 case Dot_Product_Opr : 01688 case Matmul_Opr : 01689 case Minloc_Opr : 01690 case Maxloc_Opr : 01691 case Ieee_Next_After_Opr : 01692 case Ieee_Unordered_Opr : 01693 case Ieee_Remainder_Opr : 01694 case Ieee_Int_Opr : 01695 case Ieee_Real_Opr : 01696 case Ieee_Copy_Sign_Opr : 01697 case Ieee_Binary_Scale_Opr : 01698 case Ieee_Exponent_Opr : 01699 01700 opd0 = mopd_null; 01701 opd1 = mopd_null; 01702 opd2 = mopd_null; 01703 01704 i = IR_IDX_L(ir_idx); 01705 cvrt_exp_to_mif(&opd0, blk, IL_IDX(i), IL_FLD(i), flags, value); 01706 i = IL_NEXT_LIST_IDX(i); 01707 cvrt_exp_to_mif(&opd1, blk, IL_IDX(i), IL_FLD(i), flags, value); 01708 01709 switch (IR_OPR(ir_idx)) { 01710 case Spacing_Opr : 01711 op = mop_spacing; 01712 break; 01713 case Rrspacing_Opr : 01714 op = mop_rrspcng; 01715 break; 01716 case I24mult_Opr : 01717 op = mop_i24mult; 01718 break; 01719 case Mldmx_Opr : 01720 op = mop_bmldmx; 01721 break; 01722 case All_Opr : 01723 op = mop_all; 01724 opd2 = opd0; 01725 opd0 = mopd_null; 01726 break; 01727 case Any_Opr : 01728 op = mop_any; 01729 opd2 = opd0; 01730 opd0 = mopd_null; 01731 break; 01732 case Count_Opr : 01733 op = mop_count; 01734 opd2 = opd0; 01735 opd0 = mopd_null; 01736 break; 01737 case Atan2_Opr : 01738 op = mop_atan2; 01739 break; 01740 case Cmplx_Opr : 01741 op = mop_cast; 01742 break; 01743 case Dim_Opr : 01744 op = mop_dim; 01745 break; 01746 case Mod_Opr : 01747 op = mop_rem; 01748 break; 01749 case Modulo_Opr : 01750 op = mop_mod; 01751 break; 01752 case Sign_Opr : 01753 op = mop_sign; 01754 break; 01755 case Scale_Opr : 01756 op = mop_scale; 01757 break; 01758 case Set_Exponent_Opr : 01759 op = mop_setexpo; 01760 break; 01761 case Dprod_Opr : 01762 op = mop_mul; 01763 break; 01764 case Fcd_Opr : 01765 op = mop_cast; 01766 break; 01767 case Shiftl_Opr : 01768 op = mop_lsh; 01769 opd2 = opd1; 01770 opd1 = mopd_null; 01771 break; 01772 case Shiftr_Opr : 01773 op = mop_rsh; 01774 opd2 = opd1; 01775 opd1 = opd0; 01776 opd0 = mopd_null; 01777 break; 01778 case Shifta_Opr : 01779 op = mop_mrsh; 01780 opd2 = opd1; 01781 opd1 = opd0; 01782 opd0 = mopd_null; 01783 break; 01784 case Shift_Opr : 01785 opd2 = opd1; 01786 opd1 = opd0; 01787 op = mop_lsh; 01788 break; 01789 case Dot_Product_Opr : 01790 op = mop_dotprod; 01791 break; 01792 case Matmul_Opr : 01793 op = mop_matmul; 01794 break; 01795 case Minloc_Opr : 01796 op = mop_minloc; 01797 opd2 = opd1; 01798 opd1 = mopd_null; 01799 break; 01800 case Maxloc_Opr : 01801 op = mop_maxloc; 01802 opd2 = opd1; 01803 opd1 = mopd_null; 01804 break; 01805 case Ieee_Next_After_Opr : 01806 op = mop_nextafter; 01807 break; 01808 case Ieee_Unordered_Opr : 01809 op = mop_isunordered; 01810 break; 01811 case Ieee_Remainder_Opr : 01812 op = mop_remainder; 01813 break; 01814 case Ieee_Int_Opr : 01815 op = mop_ieee_trunc; 01816 break; 01817 case Ieee_Real_Opr : 01818 op = mop_ieee_round; 01819 break; 01820 case Ieee_Copy_Sign_Opr : 01821 op = mop_sign_xfer; 01822 break; 01823 case Ieee_Binary_Scale_Opr : 01824 op = mop_scalb; 01825 break; 01826 case Ieee_Exponent_Opr : 01827 op = mop_logb; 01828 break; 01829 case Set_Ieee_Exception_Opr : 01830 op = mop_set_estat; 01831 break; 01832 case Clear_Ieee_Exception_Opr : 01833 op = mop_clr_estat; 01834 break; 01835 01836 } 01837 01838 *result = mif_opn_add(blk, op, basic, pos, flags, opd0, opd1, opd2); 01839 break; 01840 01841 01842 /* Triadic intrinsics */ 01843 case Nearest_Opr : 01844 case Dshiftl_Opr : 01845 case Dshiftr_Opr : 01846 case Cvmgp_Opr : 01847 case Cvmgm_Opr : 01848 case Cvmgz_Opr : 01849 case Cvmgn_Opr : 01850 case Cvmgt_Opr : 01851 case Csmg_Opr : 01852 case Index_Opr : 01853 case Scan_Opr : 01854 case Verify_Opr : 01855 case Cshift_Opr : 01856 case Product_Opr : 01857 case Sum_Opr : 01858 case Minval_Opr : 01859 case Maxval_Opr : 01860 case Spread_Opr : 01861 case Eoshift_Opr : 01862 01863 i = IR_IDX_L(ir_idx); 01864 cvrt_exp_to_mif(&opd0, blk, IL_IDX(i), IL_FLD(i), flags, value); 01865 i = IL_NEXT_LIST_IDX(i); 01866 cvrt_exp_to_mif(&opd1, blk, IL_IDX(i), IL_FLD(i), flags, value); 01867 i = IL_NEXT_LIST_IDX(i); 01868 cvrt_exp_to_mif(&opd2, blk, IL_IDX(i), IL_FLD(i), flags, value); 01869 01870 switch (IR_OPR(ir_idx)) { 01871 case Nearest_Opr : 01872 op = mop_nearest; 01873 break; 01874 case Dshiftl_Opr : 01875 op = mop_lsh; 01876 break; 01877 case Dshiftr_Opr : 01878 op = mop_rsh; 01879 break; 01880 case Cvmgp_Opr : 01881 case Cvmgm_Opr : 01882 case Cvmgz_Opr : 01883 case Cvmgn_Opr : 01884 case Cvmgt_Opr : 01885 op = mop_pick; 01886 break; 01887 case Csmg_Opr : 01888 op = mop_mrg; 01889 break; 01890 case Index_Opr : 01891 op = mop_chindex; 01892 break; 01893 case Scan_Opr : 01894 op = mop_chscan; 01895 break; 01896 case Verify_Opr : 01897 op = mop_chver; 01898 break; 01899 case Cshift_Opr : 01900 op = mop_cshift; 01901 break; 01902 case Product_Opr : 01903 op = mop_product; 01904 break; 01905 case Sum_Opr : 01906 op = mop_sum; 01907 break; 01908 case Minval_Opr : 01909 op = mop_minval; 01910 break; 01911 case Maxval_Opr : 01912 op = mop_maxval; 01913 break; 01914 case Spread_Opr : 01915 op = mop_spread; 01916 break; 01917 case Eoshift_Opr : 01918 cvrt_exp_to_mif(&opd2, blk, i, IL_Tbl_Idx, flags, value); 01919 op = mop_eoshift; 01920 break; 01921 } 01922 01923 *result = mif_opn_add(blk, op, basic, pos, flags, opd0, opd1, opd2); 01924 break; 01925 01926 01927 case Loc_Opr : 01928 cvrt_exp_to_mif(&opd0, 01929 blk, 01930 IR_IDX_L(ir_idx), 01931 IR_FLD_L(ir_idx), 01932 flags, 01933 value); 01934 01935 *result = mif_opn_add(blk, 01936 mop_loc, 01937 get_basic_type(IR_TYPE_IDX(ir_idx)), 01938 mpos_null, 01939 0, 01940 opd0, 01941 mopd_null, 01942 mopd_null); 01943 break; 01944 01945 01946 case Const_Tmp_Loc_Opr : 01947 cvrt_exp_to_mif(&opd0, 01948 blk, 01949 IR_IDX_L(ir_idx), 01950 IR_FLD_L(ir_idx), 01951 flags, 01952 value); 01953 01954 *result = mif_opn_add(blk, 01955 mop_loc, 01956 get_ptr_type(IR_Tbl_Idx, ir_idx), 01957 pos, 01958 flags, 01959 opd0, 01960 mopd_null, 01961 mopd_null); 01962 break; 01963 01964 01965 case Aloc_Opr : 01966 processing_aloc = TRUE; 01967 cvrt_exp_to_mif(result, blk, 01968 IR_IDX_L(ir_idx), IR_FLD_L(ir_idx), 01969 flags, address); 01970 processing_aloc = FALSE; 01971 opd2 = mopd_0; 01972 opd2.val = maliasclass_restrict; 01973 type = msp.type[mopdtype(&msp, *result, blk->opn)]; 01974 type.maddr.aliasing = maliasclass_restrict; 01975 *result = mif_opn_add(blk, mop_alias, 01976 mtype_lookup(&msp, &type), pos, flags, 01977 *result, mopd_null, opd2); 01978 break; 01979 01980 01981 case Plus_Opr : 01982 case Minus_Opr : 01983 case Mult_Opr : 01984 case Div_Opr : 01985 case Real_Div_To_Int_Opr : 01986 case Power_Opr : 01987 case And_Opr : 01988 case Band_Opr : 01989 case Or_Opr : 01990 case Bor_Opr : 01991 case Neqv_Opr : 01992 case Bneqv_Opr : 01993 case Eqv_Opr: 01994 case Beqv_Opr : 01995 case Case_Range_Opr : 01996 case Lg_Opr : 01997 01998 cvrt_exp_to_mif(&opd0, blk, 01999 IR_IDX_L(ir_idx), IR_FLD_L(ir_idx), 02000 flags, value); 02001 cvrt_exp_to_mif(&opd1, blk, 02002 IR_IDX_R(ir_idx), IR_FLD_R(ir_idx), 02003 flags, value); 02004 02005 switch (IR_OPR(ir_idx)) { 02006 case Plus_Opr : 02007 op = mop_add; 02008 break; 02009 case Minus_Opr : 02010 op = mop_sub; 02011 break; 02012 case Mult_Opr : 02013 op = mop_mul; 02014 break; 02015 case Div_Opr : 02016 op = mop_div; 02017 break; 02018 case Real_Div_To_Int_Opr : 02019 op = mop_rdiv; 02020 break; 02021 case Power_Opr : 02022 op = mop_pow; 02023 break; 02024 case And_Opr : 02025 case Band_Opr : 02026 op = mop_and; 02027 break; 02028 case Or_Opr : 02029 case Bor_Opr : 02030 op = mop_or; 02031 break; 02032 case Neqv_Opr : 02033 case Bneqv_Opr : 02034 op = mop_xor; 02035 break; 02036 case Eqv_Opr : 02037 case Beqv_Opr : 02038 op = mop_eqv; 02039 break; 02040 case Case_Range_Opr : 02041 op = mop_range; 02042 break; 02043 case Lg_Opr : 02044 op = mop_islg; 02045 break; 02046 } 02047 02048 *result = mif_opn_add(blk, op, basic, pos, 02049 flags, opd0, opd1, mopd_null); 02050 break; 02051 02052 02053 /* Relations */ 02054 case Eq_Opr : 02055 case Ne_Opr : 02056 case Lt_Opr : 02057 case Le_Opr : 02058 case Gt_Opr : 02059 case Ge_Opr : 02060 case Llt_Opr : 02061 case Lle_Opr : 02062 case Lgt_Opr : 02063 case Lge_Opr : 02064 02065 if (IR_FLD_L(ir_idx) == IL_Tbl_Idx) { 02066 i = IR_IDX_L(ir_idx); 02067 cvrt_exp_to_mif(&opd0, blk, IL_IDX(i), IL_FLD(i), flags, value); 02068 i = IL_NEXT_LIST_IDX(i); 02069 cvrt_exp_to_mif(&opd1, blk, IL_IDX(i), IL_FLD(i), flags, value); 02070 } 02071 else { 02072 cvrt_exp_to_mif(&opd0, blk, 02073 IR_IDX_L(ir_idx), IR_FLD_L(ir_idx), 02074 flags, value); 02075 cvrt_exp_to_mif(&opd1, blk, 02076 IR_IDX_R(ir_idx), IR_FLD_R(ir_idx), 02077 flags, value); 02078 } 02079 02080 opd2 = mopd_0; 02081 switch(IR_OPR(ir_idx)) { 02082 case Eq_Opr: 02083 opd2.val = mrelation_EQ; 02084 break; 02085 case Ne_Opr: 02086 opd2.val = mrelation_LT | mrelation_GT; 02087 break; 02088 case Lt_Opr : 02089 case Llt_Opr : 02090 opd2.val = mrelation_LT; 02091 break; 02092 case Le_Opr : 02093 case Lle_Opr : 02094 opd2.val = mrelation_LT | mrelation_EQ; 02095 break; 02096 case Gt_Opr : 02097 case Lgt_Opr : 02098 opd2.val = mrelation_GT; 02099 break; 02100 case Ge_Opr : 02101 case Lge_Opr : 02102 opd2.val = mrelation_GT | mrelation_EQ; 02103 break; 02104 } 02105 02106 *result = mif_opn_add(blk, mop_cmp, basic, 02107 pos, flags, opd0, opd1, opd2); 02108 break; 02109 02110 02111 /* N-ary intrinsics */ 02112 case Case_Cmic_Opr: 02113 case Guard_Cmic_Opr: 02114 case Doall_Cmic_Opr: 02115 case Doparallel_Cmic_Opr: 02116 case Parallel_Cmic_Opr: 02117 02118 opd0.tag = mtag_taskreg; 02119 opd0.val = start_task_region(blk, ir_idx, flags, pos); 02120 *result = mif_opn_add(blk, 02121 mop_tregbegin, 02122 get_basic_type(NONE), 02123 pos, 02124 flags, 02125 opd0, 02126 mopd_null, 02127 mopd_null); 02128 break; 02129 02130 02131 case Max_Opr : 02132 case Min_Opr : 02133 case Concat_Opr : 02134 02135 switch (IR_OPR(ir_idx)) { 02136 case Max_Opr : 02137 op = mop_max; 02138 break; 02139 02140 case Min_Opr : 02141 op = mop_min; 02142 break; 02143 02144 case Concat_Opr : 02145 op = mop_cat; 02146 break; 02147 02148 } 02149 02150 02151 i = 0; 02152 02153 for (temp_ir_idx = IR_IDX_L(ir_idx); 02154 temp_ir_idx != NULL_IDX; 02155 temp_ir_idx = IL_NEXT_LIST_IDX(temp_ir_idx)) { 02156 02157 if (IL_IDX(temp_ir_idx) != NULL_IDX) { 02158 02159 if (!i++) { 02160 /* First operand */ 02161 cvrt_exp_to_mif(result, blk, 02162 IL_IDX(temp_ir_idx), IL_FLD(temp_ir_idx), 02163 flags, value); 02164 } 02165 else { 02166 02167 cvrt_exp_to_mif(&opd1, blk, 02168 IL_IDX(temp_ir_idx), IL_FLD(temp_ir_idx), 02169 flags, value); 02170 02171 if (opd1.tag == mtag_sx && 02172 blk->opn[opd1.val].flags & mopnflag_array) { 02173 flags |= mopnflag_array; 02174 } 02175 02176 *result = mif_opn_add(blk, op, basic, pos, flags, 02177 *result, opd1, mopd_null); 02178 } 02179 } 02180 } 02181 02182 break; 02183 02184 02185 /* Assignment */ 02186 case Asg_Opr : 02187 case Ptr_Asg_Opr: 02188 case Alt_Return_Opr : 02189 case Dv_Whole_Copy_Opr : 02190 02191 if ((IR_FLD_L(ir_idx) == AT_Tbl_Idx) && 02192 (AT_OBJ_CLASS(IR_IDX_L(ir_idx)) == Label)) { 02193 02194 attr_idx = IR_IDX_L(ir_idx); 02195 mif_attr_map[attr_idx].val = cvrt_label(attr_idx, flags, pos); 02196 02197 /* compute address of label */ 02198 type = *mtype_null[mtypeclass_blkaddr]; 02199 type.mblkaddr.size = mint(&msp, 02200 msp.immtype, 02201 (unsigned long)TARGET_BITS_PER_WORD); 02202 02203 opd1 = mif_opn_add(blk, 02204 mop_loc, 02205 mtype_lookup(&msp, &type), 02206 pos, 02207 flags, 02208 mif_attr_map[attr_idx], 02209 mopd_null, 02210 mopd_null); 02211 02212 /* store it */ 02213 op = mop_asg; 02214 opd0 = mif_attr_map[IR_IDX_R(ir_idx)]; 02215 } 02216 else { 02217 02218 /* RHS */ 02219 cvrt_exp_to_mif(&opd1, 02220 blk, 02221 IR_IDX_R(ir_idx), 02222 IR_FLD_R(ir_idx), 02223 flags, 02224 value); 02225 02226 if (IR_FLD_L(ir_idx) == AT_Tbl_Idx && 02227 AT_OBJ_CLASS(IR_IDX_L(ir_idx)) == Data_Obj && 02228 ATD_CLASS(IR_IDX_L(ir_idx)) != Dummy_Argument) { 02229 /* direct assignment */ 02230 opd0 = mif_attr_map[IR_IDX_L(ir_idx)]; 02231 op = mop_asg; 02232 } 02233 else { 02234 cvrt_exp_to_mif(&opd0, 02235 blk, 02236 IR_IDX_L(ir_idx), 02237 IR_FLD_L(ir_idx), 02238 flags, 02239 address); 02240 op = mop_st; 02241 } 02242 02243 } 02244 02245 mif_opn_add(blk, 02246 op, 02247 get_basic_type(NONE), 02248 pos, 02249 flags, 02250 opd0, 02251 opd1, 02252 mopd_null); 02253 break; 02254 02255 02256 02257 02258 case Flat_Array_Asg_Opr : 02259 /* RHS */ 02260 cvrt_exp_to_mif(&opd1, 02261 blk, 02262 IR_IDX_R(ir_idx), 02263 IR_FLD_R(ir_idx), 02264 flags, 02265 value); 02266 02267 cvrt_exp_to_mif(&opd0, 02268 blk, 02269 IR_IDX_L(ir_idx), 02270 IR_FLD_L(ir_idx), 02271 flags, 02272 address); 02273 op = mop_constr; 02274 02275 mif_opn_add(blk, 02276 op, 02277 get_basic_type(NONE), 02278 pos, 02279 flags, 02280 opd0, 02281 opd1, 02282 mopd_null); 02283 break; 02284 02285 02286 02287 02288 02289 02290 case Dv_Def_Asg_Opr : 02291 cvrt_exp_to_mif(&opd0, 02292 blk, 02293 IR_IDX_L(ir_idx), 02294 IR_FLD_L(ir_idx), 02295 flags, 02296 address); 02297 02298 cvrt_exp_to_mif(&opd1, 02299 blk, 02300 IR_IDX_L(IR_IDX_R(ir_idx)), 02301 IR_FLD_L(IR_IDX_R(ir_idx)), 02302 flags, 02303 value); 02304 02305 mif_opn_add(blk, 02306 mop_dvdef, 02307 get_basic_type(NONE), 02308 pos, 02309 flags, 02310 opd0, 02311 opd1, 02312 mopd_null); 02313 break; 02314 02315 02316 02317 02318 /* case Ptr_Asg_Opr : 02319 02320 cvrt_exp_to_mif(&opd1, blk, 02321 IR_IDX_R(ir_idx), 02322 IR_FLD_R(ir_idx), 02323 flags, 02324 address); 02325 02326 cvrt_exp_to_mif(&opd0, 02327 blk, 02328 IR_IDX_L(ir_idx), 02329 IR_FLD_L(ir_idx), 02330 flags, 02331 value); 02332 02333 attr_idx = find_base_attr(&IR_OPND_R(ir_idx), &unused1, &unused2); 02334 02335 opd0 = mif_opn_add(blk, 02336 mop_dvfield, 02337 get_ptr_type(AT_Tbl_Idx, attr_idx), 02338 pos, 02339 flags, 02340 opd0, 02341 mopd_1, 02342 mopd_null); /* field 1: base address */ 02343 02344 mif_opn_add(blk, 02345 mop_st, 02346 get_basic_type(NONE), 02347 pos, 02348 flags, 02349 opd0, 02350 opd1, 02351 mopd_null); 02352 break; 02353 */ 02354 02355 02356 case Where_Opr : 02357 02358 /* LHS */ 02359 i = IR_IDX_L(ir_idx); 02360 cvrt_exp_to_mif(&opd0, 02361 blk, 02362 IL_IDX(i), 02363 IL_FLD(i), 02364 flags, 02365 address); 02366 02367 /* Mask */ 02368 i = IL_NEXT_LIST_IDX(i); 02369 cvrt_exp_to_mif(&opd2, 02370 blk, 02371 IL_IDX(i), 02372 IL_FLD(i), 02373 flags, 02374 value); 02375 02376 opd0 = mif_opn_add(blk, mop_where, mopdtype(&msp, opd0, 02377 blk->opn), pos, 02378 flags | mopnflag_distinct, 02379 opd0, opd2, mopd_null); 02380 02381 /* RHS */ 02382 i = IL_NEXT_LIST_IDX(i); 02383 cvrt_exp_to_mif(&opd1, blk, 02384 IL_IDX(i), IL_FLD(i), 02385 flags, value); 02386 02387 /* Explicit conversion */ 02388 if (VALID (basic) && 02389 mopdtype(&msp, opd1, blk->opn) != basic && 02390 msp.type[basic].u.class != mtypeclass_fchar) { 02391 opd1 = mif_opn_add(blk, mop_cast, basic, pos, flags, 02392 opd1, mopd_null, mopd_null); 02393 } 02394 02395 mif_opn_add(blk, 02396 mop_st, 02397 get_basic_type(NONE), 02398 pos, 02399 flags, 02400 opd0, 02401 opd1, 02402 mopd_null); 02403 break; 02404 02405 02406 02407 case Read_Formatted_Opr : 02408 case Write_Formatted_Opr : 02409 case Read_Unformatted_Opr : 02410 case Write_Unformatted_Opr : 02411 case Read_Namelist_Opr : 02412 case Write_Namelist_Opr : 02413 02414 /* control list */ 02415 cvrt_exp_to_mif(&opd0, 02416 blk, 02417 IR_IDX_L(ir_idx), 02418 IR_FLD_L(ir_idx), 02419 flags, 02420 value); 02421 02422 /* I/O list */ 02423 cvrt_exp_to_mif(&opd1, 02424 blk, 02425 IR_IDX_R(ir_idx), 02426 IR_FLD_R(ir_idx), 02427 flags, 02428 value); 02429 02430 opd2 = mopd_0; 02431 02432 switch(IR_OPR(ir_idx)) { 02433 case Read_Formatted_Opr : 02434 case Read_Unformatted_Opr : 02435 case Read_Namelist_Opr : 02436 opd2.val |= mIOflag_read; 02437 break; 02438 case Write_Formatted_Opr : 02439 case Write_Unformatted_Opr : 02440 case Write_Namelist_Opr : 02441 opd2.val |= mIOflag_write; 02442 break; 02443 } 02444 switch(IR_OPR(ir_idx)) { 02445 case Read_Formatted_Opr : 02446 case Write_Formatted_Opr : 02447 opd2.val |= mIOflag_formatted; 02448 break; 02449 case Read_Unformatted_Opr : 02450 case Write_Unformatted_Opr : 02451 opd2.val |= mIOflag_unformatted; 02452 break; 02453 case Read_Namelist_Opr : 02454 case Write_Namelist_Opr : 02455 opd2.val |= mIOflag_namelist; 02456 break; 02457 } 02458 02459 *result = mif_opn_add(blk, 02460 mop_IO, 02461 msp.immtype, 02462 pos, 02463 flags, 02464 opd0, 02465 opd1, 02466 opd2); 02467 break; 02468 02469 02470 case Inquire_Iolength_Opr: 02471 /* length */ 02472 cvrt_exp_to_mif(&opd0, 02473 blk, 02474 IR_IDX_L(ir_idx), 02475 IR_FLD_L(ir_idx), 02476 flags, 02477 value); 02478 02479 /* I/O list */ 02480 cvrt_exp_to_mif(&opd1, 02481 blk, 02482 IR_IDX_R(ir_idx), 02483 IR_FLD_R(ir_idx), 02484 flags, 02485 value); 02486 02487 *result = mif_opn_add(blk, 02488 mop_IOlength, basic, 02489 pos, 02490 flags, 02491 opd0, 02492 opd1, 02493 mopd_null); 02494 break; 02495 02496 case Implied_Do_Opr : 02497 02498 /* This code is simplier than functional interface code because 02499 * Init_Opr does much of the work. */ 02500 02501 j = IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx)); 02502 cvrt_exp_to_mif(&opd0, blk, IL_IDX(j), IL_FLD(j), flags, value); 02503 j = IL_NEXT_LIST_IDX(j); 02504 cvrt_exp_to_mif(&opd1, blk, IL_IDX(j), IL_FLD(j), flags, value); 02505 j = IL_NEXT_LIST_IDX(j); 02506 cvrt_exp_to_mif(&opd2, blk, IL_IDX(j), IL_FLD(j), flags, value); 02507 02508 /* Turn on flag to do array syntax expansion. */ 02509 opd2 = mif_opn_add(blk, mop_triplet, msp.immtype, pos, 02510 flags | mopnflag_array, 02511 opd0, opd1, opd2); 02512 02513 /* I/O list */ 02514 cvrt_exp_to_mif(&opd0, 02515 blk, 02516 IR_IDX_L(ir_idx), 02517 IR_FLD_L(ir_idx), 02518 flags, 02519 value); 02520 02521 /* Control variable */ 02522 cvrt_exp_to_mif(&opd1, 02523 blk, 02524 IL_IDX(IR_IDX_R(ir_idx)), 02525 IL_FLD(IR_IDX_R(ir_idx)), 02526 flags, 02527 value); 02528 02529 *result = mif_opn_add(blk, mop_implDO, msp.immtype, pos, 02530 flags | mopnflag_array, 02531 opd0, opd1, opd2); 02532 break; 02533 02534 02535 case Call_Opr : 02536 02537 if (ATP_PROC(IR_IDX_L(ir_idx)) == Dummy_Proc) { 02538 if (TYP_TYPE(IR_TYPE_IDX(ir_idx)) == Typeless) { 02539 basic = get_basic_type(NONE); 02540 } 02541 } 02542 else if (ATP_HAS_ALT_RETURN(IR_IDX_L(ir_idx))) { 02543 basic = msp.immtype; 02544 } 02545 else if (ATP_PGM_UNIT(IR_IDX_L(ir_idx)) == Subroutine || 02546 ATP_EXTRA_DARG(IR_IDX_L(ir_idx)) || 02547 INVALID (basic)) { 02548 basic = get_basic_type(NONE); 02549 } 02550 02551 /* Destination */ 02552 cvrt_exp_to_mif(&opd0, 02553 blk, 02554 IR_IDX_L(ir_idx), 02555 IR_FLD_L(ir_idx), 02556 flags, 02557 value); 02558 02559 /* Args */ 02560 if (IR_IDX_R(ir_idx) != NULL_IDX) { 02561 cvrt_exp_to_mif(&opd1, blk, 02562 IR_IDX_R(ir_idx), 02563 IR_FLD_R(ir_idx), 02564 flags, 02565 value); 02566 } 02567 else { 02568 opd1 = mopd_null; 02569 } 02570 02571 if (cdir_switches.do_inline) { 02572 02573 /* Turn on inlining if !DIR$ INLINE is specified or if inline */ 02574 /* level is Inline_Lvl_2 or Inline_Lvl_3. Do not turn it on */ 02575 /* if !DIR$ INLINE NEVER is specified for the callee. */ 02576 02577 if (!ATP_INLINE_NEVER(IR_IDX_L(ir_idx))) { 02578 flags |= mopnflag_inline; 02579 } 02580 } 02581 else if (opt_flags.inline_lvl > 0 && 02582 ATP_INLINE_ALWAYS(IR_IDX_L(ir_idx))) { 02583 flags |= mopnflag_inline; 02584 } 02585 else if (cdir_switches.noinline || opt_flags.inline_lvl == 0) { 02586 flags |= mopnflag_noinline; 02587 } 02588 02589 *result = mif_opn_add(blk, 02590 mop_call, 02591 basic, pos, flags, 02592 opd0, opd1, mopd_null); 02593 break; 02594 02595 02596 case Whole_Subscript_Opr : 02597 case Section_Subscript_Opr : 02598 case Subscript_Opr : 02599 02600 base_attr = find_left_attr(&(IR_OPND_L(ir_idx))); 02601 02602 bound_chk = (cdir_switches.bounds || 02603 ATD_BOUNDS_CHECK(base_attr)) && 02604 ! ATD_NOBOUNDS_CHECK(base_attr); 02605 02606 /* base variable */ 02607 cvrt_exp_to_mif(&opd0, blk, 02608 IR_IDX_L(ir_idx), 02609 IR_FLD_L(ir_idx), 02610 flags, address); 02611 02612 opd1 = mopd_null; 02613 02614 /* i_cvrt.c contains code to test IR_CONTIG_ARRAY and omit the */ 02615 /* emission of the subscripts if the reference is a whole array */ 02616 /* reference to an array with contiguous storage. To ease the */ 02617 /* job of array syntax translation, we'll always use explicit */ 02618 /* triplets in the textual interface instead. */ 02619 for (next_idx = IR_IDX_R(ir_idx); 02620 next_idx != NULL_IDX; 02621 next_idx = IL_NEXT_LIST_IDX(next_idx)) { 02622 02623 cvrt_exp_to_mif(&opd, blk, 02624 IL_IDX(next_idx), 02625 IL_FLD(next_idx), 02626 flags, value); 02627 02628 opd1 = mif_opn_add(blk, 02629 mop_list, 02630 mopdtype(&msp, opd, blk->opn), 02631 pos, 02632 flags, 02633 opd, 02634 opd1, 02635 mopd_null); 02636 } 02637 02638 save_flags = flags; 02639 02640 if (bound_chk) { 02641 flags |= mopnflag_validate; 02642 } 02643 02644 *result = mif_opn_add(blk, 02645 mop_index, 02646 get_ptr_type(IR_Tbl_Idx, ir_idx), 02647 pos, 02648 flags, 02649 opd0, 02650 opd1, 02651 mopd_null); 02652 02653 /* Explicit loads */ 02654 if (context == value) { 02655 02656 flags = save_flags; 02657 02658 *result = mif_opn_add(blk, 02659 mop_ld, 02660 basic, 02661 pos, 02662 flags, 02663 *result, 02664 mopd_null, 02665 mopd_null); 02666 } 02667 02668 break; 02669 02670 02671 case Triplet_Opr : 02672 02673 i = IR_IDX_L(ir_idx); /* list of (start, limit, stride) */ 02674 cvrt_exp_to_mif(&opd0, blk, IL_IDX(i), IL_FLD(i), flags, value); 02675 i = IL_NEXT_LIST_IDX(i); 02676 cvrt_exp_to_mif(&opd1, blk, IL_IDX(i), IL_FLD(i), flags, value); 02677 i = IL_NEXT_LIST_IDX(i); 02678 cvrt_exp_to_mif(&opd2, blk, IL_IDX(i), IL_FLD(i), flags, value); 02679 02680 /* Turn on flag to do array syntax expansion. */ 02681 *result = mif_opn_add(blk, 02682 mop_triplet, 02683 basic, 02684 pos, 02685 flags | mopnflag_array, 02686 opd0, 02687 opd1, 02688 opd2); 02689 break; 02690 02691 02692 case Whole_Substring_Opr : 02693 case Substring_Opr : 02694 02695 base_attr = find_left_attr(&(IR_OPND_L(ir_idx))); 02696 02697 bound_chk = cmd_line_flags.runtime_substring; 02698 02699 /* Base variable */ 02700 cvrt_exp_to_mif(&opd0, blk, 02701 IR_IDX_L(ir_idx), 02702 IR_FLD_L(ir_idx), 02703 flags, address); 02704 02705 /* get starting index */ 02706 i = IR_IDX_R(ir_idx); /* list of (start index, end index, length) */ 02707 cvrt_exp_to_mif(&opd1, blk, IL_IDX(i), IL_FLD(i), flags, value); 02708 02709 /* get the length */ 02710 i = IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(i)); 02711 cvrt_exp_to_mif(&opd2, blk, IL_IDX(i), IL_FLD(i), flags, value); 02712 02713 save_flags = flags; 02714 02715 if (bound_chk) { 02716 flags |= mopnflag_validate; 02717 } 02718 02719 *result = mif_opn_add(blk, mop_substr, get_ptr_type(IR_Tbl_Idx, ir_idx), 02720 pos, flags & ~mopnflag_array, 02721 opd0, opd1, opd2); 02722 02723 /* Explicit loads */ 02724 if (context == value) { 02725 02726 flags = save_flags; 02727 02728 *result = mif_opn_add(blk, 02729 mop_ld, 02730 basic, 02731 pos, 02732 flags, 02733 *result, 02734 mopd_null, 02735 mopd_null); 02736 } 02737 02738 break; 02739 02740 02741 case Struct_Opr : 02742 02743 /* base variable */ 02744 cvrt_exp_to_mif(&opd0, blk, 02745 IR_IDX_L(ir_idx), IR_FLD_L(ir_idx), 02746 flags, address); 02747 02748 /* component */ 02749 if (IR_FLD_R(ir_idx) == AT_Tbl_Idx && 02750 AT_OBJ_CLASS(IR_IDX_R(ir_idx)) == Data_Obj) { 02751 opd1 = mif_attr_map[IR_IDX_R(ir_idx)]; 02752 typeix = get_ptr_type(AT_Tbl_Idx, IR_IDX_R(ir_idx)); 02753 } 02754 else { 02755 cvrt_exp_to_mif(&opd1, blk, 02756 IR_IDX_R(ir_idx), 02757 IR_FLD_R(ir_idx), 02758 flags, 02759 value); 02760 02761 typeix = get_ptr_type(IR_Tbl_Idx, ir_idx); 02762 } 02763 02764 *result = mif_opn_add(blk, 02765 mop_field, 02766 typeix, pos, flags, 02767 opd0, 02768 opd1, 02769 mopd_null); 02770 02771 /* Explicit load */ 02772 if (context==value) { 02773 /* result type is type of field member */ 02774 *result = mif_opn_add(blk, mop_ld, 02775 msp.type[typeix].u.base, pos, flags, 02776 *result, mopd_null, mopd_null); 02777 } 02778 break; 02779 02780 02781 /* Dope vector operations */ 02782 02783 case Dv_Deref_Opr : 02784 cvrt_exp_to_mif(result, 02785 blk, 02786 IR_IDX_L(ir_idx), 02787 IR_FLD_L(ir_idx), 02788 flags, 02789 value); 02790 02791 /* If value is needed, dereference dope vector via a mop_ld. */ 02792 /* Note: mop_ld has a dope vector instead of an address as an operand */ 02793 /* Result type is the basic type referenced by the dope vector. */ 02794 if (context == value) { 02795 *result = mif_opn_add(blk, 02796 mop_ld, 02797 basic, 02798 pos, 02799 flags, 02800 *result, 02801 mopd_null, 02802 mopd_null); 02803 } 02804 break; 02805 02806 02807 case Dv_Access_Base_Addr : 02808 case Dv_Set_Base_Addr : 02809 case Dv_Access_El_Len : 02810 case Dv_Set_El_Len : 02811 case Dv_Access_N_Dim : 02812 case Dv_Set_N_Dim : 02813 case Dv_Access_Assoc : 02814 case Dv_Set_Assoc : 02815 case Dv_Access_Ptr_Alloc : 02816 case Dv_Set_Ptr_Alloc : 02817 case Dv_Access_P_Or_A : 02818 case Dv_Set_P_Or_A : 02819 case Dv_Access_A_Contig : 02820 case Dv_Set_A_Contig : 02821 case Dv_Access_Typ_Code : 02822 case Dv_Set_Typ_Code : 02823 case Dv_Access_Orig_Base : 02824 case Dv_Set_Orig_Base : 02825 case Dv_Access_Orig_Size : 02826 case Dv_Set_Orig_Size : 02827 case Dv_Access_Low_Bound : 02828 case Dv_Set_Low_Bound : 02829 case Dv_Access_Extent : 02830 case Dv_Set_Extent : 02831 case Dv_Access_Stride_Mult : 02832 case Dv_Set_Stride_Mult : 02833 02834 cvrt_exp_to_mif(&opd0, 02835 blk, 02836 IR_IDX_L(ir_idx), 02837 IR_FLD_L(ir_idx), 02838 flags, 02839 value); 02840 02841 /* First operand is field being accessed. */ 02842 opd1 = mopd_0; 02843 switch (IR_OPR(ir_idx)) { 02844 /* Has no dimension operand */ 02845 case Dv_Set_Base_Addr : /* BECKER - overloading with Ptr_Asg_Opr 02846 ** even though i_cvrt.c used different 02847 ** interface */ 02848 case Dv_Access_Base_Addr : opd1.val = 1; break; 02849 case Dv_Set_El_Len : 02850 case Dv_Access_El_Len : opd1.val = 2; break; 02851 case Dv_Set_Assoc : 02852 case Dv_Access_Assoc : opd1.val = 3; break; 02853 case Dv_Set_Ptr_Alloc : 02854 case Dv_Access_Ptr_Alloc : opd1.val = 4; break; 02855 case Dv_Set_P_Or_A : 02856 case Dv_Access_P_Or_A : opd1.val = 5; break; 02857 case Dv_Set_A_Contig : 02858 case Dv_Access_A_Contig : opd1.val = 6; break; 02859 case Dv_Set_N_Dim : 02860 case Dv_Access_N_Dim : opd1.val = 7; break; 02861 case Dv_Set_Typ_Code : 02862 case Dv_Access_Typ_Code : opd1.val = 8; break; 02863 case Dv_Set_Orig_Base : 02864 case Dv_Access_Orig_Base : opd1.val = 9; break; 02865 case Dv_Set_Orig_Size : 02866 case Dv_Access_Orig_Size : opd1.val = 10; break; 02867 02868 /* Has dimension operand */ 02869 case Dv_Set_Low_Bound : 02870 case Dv_Access_Low_Bound : opd1.val = 0; break; 02871 case Dv_Set_Extent : 02872 case Dv_Access_Extent : opd1.val = 1; break; 02873 case Dv_Set_Stride_Mult : 02874 case Dv_Access_Stride_Mult : opd1.val = 2; break; 02875 } 02876 02877 /* Second operand is dimension being accessed. */ 02878 opd2 = mopd_null; 02879 switch (IR_OPR(ir_idx)) { 02880 case Dv_Set_Low_Bound : 02881 case Dv_Access_Low_Bound : 02882 case Dv_Set_Extent : 02883 case Dv_Access_Extent : 02884 case Dv_Set_Stride_Mult : 02885 case Dv_Access_Stride_Mult : 02886 opd2 = mopd_0; 02887 opd2.val = IR_DV_DIM(ir_idx); 02888 } 02889 02890 opd0 = mif_opn_add(blk, 02891 mop_dvfield, 02892 get_ptr_type(IR_Tbl_Idx, ir_idx), 02893 pos, 02894 flags, 02895 opd0, 02896 opd1, 02897 opd2); 02898 02899 /* Create a load or store of field reference. */ 02900 opd1 = mopd_null; 02901 switch (IR_OPR(ir_idx)) { 02902 case Dv_Set_Base_Addr : 02903 case Dv_Set_El_Len : 02904 case Dv_Set_Assoc : 02905 case Dv_Set_Ptr_Alloc : 02906 case Dv_Set_P_Or_A : 02907 case Dv_Set_A_Contig : 02908 case Dv_Set_N_Dim : 02909 case Dv_Set_Typ_Code : 02910 case Dv_Set_Orig_Base : 02911 case Dv_Set_Orig_Size : 02912 case Dv_Set_Low_Bound : 02913 case Dv_Set_Extent : 02914 case Dv_Set_Stride_Mult : 02915 cvrt_exp_to_mif(&opd1, 02916 blk, 02917 IR_IDX_R(ir_idx), 02918 IR_FLD_R(ir_idx), 02919 flags, 02920 value); 02921 /* Set a field */ 02922 op = mop_st; 02923 basic = get_basic_type(NONE); 02924 break; 02925 02926 default : 02927 /* Load a field */ 02928 op = mop_ld; 02929 } 02930 02931 *result = mif_opn_add(blk, op, basic, pos, 02932 flags, opd0, opd1, mopd_null); 02933 break; 02934 02935 02936 #if ! defined _ALLOCATE_IS_CALL 02937 case Allocate_Opr: 02938 case Deallocate_Opr: 02939 cvrt_exp_to_mif(&opd0, blk, IR_IDX_R(ir_idx), IR_FLD_R(ir_idx), 02940 flags, 02941 value); 02942 02943 cvrt_exp_to_mif(&opd1, blk, IR_IDX_L(ir_idx), IR_FLD_L(ir_idx), 02944 flags, 02945 value); 02946 02947 *result = mif_opn_add(blk, 02948 mop_allocate, 02949 get_basic_type(NONE), 02950 pos, 02951 flags, 02952 opd0, 02953 opd1, 02954 mopd_null); 02955 break; 02956 #endif 02957 02958 case SSD_Alloc_Opr : 02959 case Alloc_Opr : 02960 02961 cvrt_exp_to_mif(&opd0, blk, 02962 IR_IDX_L(ir_idx), 02963 IR_FLD_L(ir_idx), 02964 flags, 02965 value); 02966 02967 /* convert words to bytes */ 02968 opd1 = mopd_0; 02969 # ifdef _HEAP_REQUEST_IN_WORDS 02970 opd1.val = 8; /* convert to bytes */ 02971 # else 02972 opd1.val = 1; /* leave as bytes */ 02973 # endif 02974 opd0 = mif_opn_add(blk, 02975 mop_mul, 02976 msp.immtype, 02977 pos, 02978 flags, 02979 opd0, 02980 opd1, 02981 mopd_null); 02982 02983 02984 op = IR_OPR(ir_idx) == SSD_Alloc_Opr ? mop_SSD : mop_alloc; 02985 02986 /* Have to create pointer type of result because */ 02987 /* frontend treats result of alloc as int. */ 02988 *result = mif_opn_add(blk, 02989 op, 02990 get_ptr_type(IR_Tbl_Idx, ir_idx), 02991 pos, flags, 02992 opd0, 02993 mopd_null, 02994 mopd_null); 02995 break; 02996 02997 02998 case Dealloc_Opr : 02999 case SSD_Dealloc_Opr : 03000 cvrt_exp_to_mif(&opd0, 03001 blk, 03002 IR_IDX_L(ir_idx), 03003 IR_FLD_L(ir_idx), 03004 flags, 03005 value); 03006 03007 /* Cast to pointer type, frontend keeps address in int variable. */ 03008 opd0 = mif_opn_add(blk, 03009 mop_cast, 03010 get_ptr_type(IR_Tbl_Idx, ir_idx), 03011 pos, 03012 flags, 03013 opd0, 03014 mopd_null, 03015 mopd_null); 03016 03017 op = IR_OPR(ir_idx) == SSD_Dealloc_Opr ? mop_SSDfree : mop_free; 03018 03019 *result = mif_opn_add(blk, 03020 op, 03021 get_basic_type(NONE), 03022 pos, 03023 flags, 03024 opd0, 03025 mopd_null, 03026 mopd_null); 03027 break; 03028 03029 default: 03030 PRINTMSG(IR_LINE_NUM(ir_idx), 03031 1044, 03032 Internal, 03033 IR_COL_NUM(ir_idx), 03034 "cvrt_exp_to_mif: unexpected operator"); 03035 break; 03036 03037 } 03038 break; 03039 03040 } 03041 03042 TRACE (Func_Exit, "cvrt_exp_to_mif", NULL); 03043 } /* cvrt_exp_to_mif */ 03044 03045 03046 03047 /******************************************************************************\ 03048 |* *| 03049 |* Description: *| 03050 |* Translate the code of a scope into blocks and arcs. *| 03051 |* *| 03052 |* Input parameters: *| 03053 |* Subprogram *| 03054 |* Scope *| 03055 |* *| 03056 |* Output parameters: *| 03057 |* NONE *| 03058 |* *| 03059 |* Returns: *| 03060 |* NOTHING *| 03061 |* *| 03062 \******************************************************************************/ 03063 static void cvrt_ir_to_mif(int scp_idx) 03064 { 03065 int attr_idx; 03066 int baseattr; 03067 int basic; 03068 int blkix = NONE; 03069 int case_ct; 03070 size_offset_type char_bit; 03071 int cn_idx; 03072 int curr_sh; 03073 mopnflag_t flags; 03074 int fldattr; 03075 int i, j; 03076 int idx; 03077 int initix; 03078 int ir_idx; 03079 int l_idx; 03080 int lastblkix; 03081 int lcv; 03082 int length; 03083 int list_idx1; 03084 int list_idx2; 03085 int loc_offset_idx; 03086 int lt0, eq0, gt0; 03087 int nested_case_ct; 03088 mopn_t *o; 03089 long offset; 03090 size_offset_type offset1; 03091 mop_t op; 03092 mopd_t opd, opd0, opd1, opd2; 03093 opnd_type opnd; 03094 int opnix; 03095 mpos_t pos; 03096 size_offset_type result; 03097 long t; 03098 int tmp_sh; 03099 mtype_t typ; 03100 int typeix; 03101 boolean unused; 03102 03103 03104 TRACE (Func_Entry, "cvrt_ir_to_mif", NULL); 03105 03106 /* process each statement of function */ 03107 for (curr_sh = SCP_FIRST_SH_IDX(scp_idx); 03108 curr_sh != NULL_IDX; 03109 curr_sh = SH_NEXT_IDX(curr_sh)) { 03110 03111 /* Determine the source code position of the operation. */ 03112 pos = mpos_null; 03113 pos.line = source_position(SH_GLB_LINE(curr_sh)); 03114 pos.src = srcix; 03115 pos.col = SH_COL_NUM(curr_sh); 03116 03117 msp.scope[local_scope].end.line = pos.line; 03118 msp.scope[local_scope].end.src = pos.src; 03119 03120 if (VALID(host_scope)) { 03121 msp.scope[host_scope].end.line = pos.line; 03122 msp.scope[host_scope].end.src = pos.src; 03123 } 03124 03125 flags = 0; 03126 if (SH_COMPILER_GEN(curr_sh)) { 03127 flags |= mopnflag_syn; /* mark compiler-generated operations */ 03128 } 03129 03130 ir_idx = SH_IR_IDX(curr_sh); 03131 if (ir_idx != NULL_IDX) { 03132 03133 switch(IR_OPR(ir_idx)) { 03134 03135 /* Operators that introduce control flow or generate no code. */ 03136 case Vector_Cdir_Opr : 03137 case Novector_Cdir_Opr : 03138 case Ivdep_Cdir_Opr : 03139 case Unroll_Cdir_Opr : 03140 case Nounroll_Cdir_Opr : 03141 case Vsearch_Cdir_Opr : 03142 case Novsearch_Cdir_Opr : 03143 case Recurrence_Cdir_Opr : 03144 case Norecurrence_Cdir_Opr : 03145 case Cachealign_Cdir_Opr : 03146 case Align_Cdir_Opr : 03147 case Nextscalar_Cdir_Opr : 03148 case Shortloop128_Cdir_Opr : 03149 case Shortloop_Cdir_Opr: 03150 case Task_Cdir_Opr: 03151 case Notask_Cdir_Opr: 03152 case Prefervector_Cdir_Opr: 03153 case Prefertask_Cdir_Opr: 03154 case Bl_Cdir_Opr: 03155 case Nobl_Cdir_Opr: 03156 case Permutation_Cmic_Opr: 03157 case Cncall_Cmic_Opr: 03158 case Maxcpus_Cmic_Opr: 03159 break; /* ignore */ 03160 03161 03162 case Inline_Cdir_Opr : 03163 cdir_switches.do_inline = TRUE; 03164 cdir_switches.noinline = FALSE; 03165 break; 03166 03167 case Noinline_Cdir_Opr : 03168 cdir_switches.do_inline = FALSE; 03169 cdir_switches.noinline = TRUE; 03170 break; 03171 03172 case Bounds_Cdir_Opr : 03173 if (IR_FLD_L(ir_idx) == IL_Tbl_Idx) { 03174 list_idx1 = IR_IDX_L(ir_idx); 03175 03176 while (list_idx1) { 03177 attr_idx = IL_IDX(list_idx1); 03178 03179 /* if ATD_NOBOUNDS_CHECK set, */ 03180 /* clear and remove from nobounds list */ 03181 03182 if (ATD_NOBOUNDS_CHECK(attr_idx)) { 03183 ATD_NOBOUNDS_CHECK(attr_idx) = FALSE; 03184 list_idx2 = cdir_switches.nobounds_il_list; 03185 03186 while (list_idx2 != NULL_IDX) { 03187 if (IL_IDX(list_idx2) == attr_idx) { 03188 /* remove the attr from the list */ 03189 03190 if (list_idx2 == cdir_switches.nobounds_il_list) { 03191 cdir_switches.nobounds_il_list = 03192 IL_NEXT_LIST_IDX(list_idx2); 03193 if (cdir_switches.nobounds_il_list) { 03194 IL_PREV_LIST_IDX( 03195 cdir_switches.nobounds_il_list) = 03196 NULL_IDX; 03197 } 03198 } 03199 else { 03200 IL_NEXT_LIST_IDX(IL_PREV_LIST_IDX(list_idx2)) = 03201 IL_NEXT_LIST_IDX(list_idx2); 03202 if (IL_NEXT_LIST_IDX(list_idx2)) { 03203 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = 03204 IL_PREV_LIST_IDX(list_idx2); 03205 } 03206 } 03207 FREE_IR_LIST_NODE(list_idx2); 03208 03209 break; 03210 } 03211 list_idx2 = IL_NEXT_LIST_IDX(list_idx2); 03212 } 03213 } 03214 03215 /* now add to bounds list if not already there */ 03216 03217 if (ATD_BOUNDS_CHECK(attr_idx) == FALSE) { 03218 ATD_BOUNDS_CHECK(attr_idx) = TRUE; 03219 03220 NTR_IR_LIST_TBL(list_idx2); 03221 IL_FLD(list_idx2) = AT_Tbl_Idx; 03222 IL_IDX(list_idx2) = attr_idx; 03223 03224 IL_NEXT_LIST_IDX(list_idx2) = cdir_switches.bounds_il_list; 03225 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2; 03226 cdir_switches.bounds_il_list = list_idx2; 03227 } 03228 03229 list_idx1 = IL_NEXT_LIST_IDX(list_idx1); 03230 } 03231 } 03232 else { 03233 cdir_switches.bounds = TRUE; 03234 03235 /* clear the NOBOUNDS flag on all attrs in the nobounds list */ 03236 03237 list_idx1 = cdir_switches.nobounds_il_list; 03238 cdir_switches.nobounds_il_list = NULL_IDX; 03239 03240 while (list_idx1) { 03241 attr_idx = IL_IDX(list_idx1); 03242 ATD_NOBOUNDS_CHECK(attr_idx) = FALSE; 03243 03244 list_idx2 = list_idx1; 03245 list_idx1 = IL_NEXT_LIST_IDX(list_idx1); 03246 FREE_IR_LIST_NODE(list_idx2); 03247 } 03248 } 03249 break; 03250 03251 case Nobounds_Cdir_Opr : 03252 03253 if (IR_FLD_L(ir_idx) == IL_Tbl_Idx) { 03254 list_idx1 = IR_IDX_L(ir_idx); 03255 03256 while (list_idx1) { 03257 attr_idx = IL_IDX(list_idx1); 03258 03259 /* if ATD_BOUNDS_CHECK set, */ 03260 /* clear and remove from bounds list */ 03261 03262 if (ATD_BOUNDS_CHECK(attr_idx)) { 03263 ATD_BOUNDS_CHECK(attr_idx) = FALSE; 03264 list_idx2 = cdir_switches.bounds_il_list; 03265 03266 while (list_idx2 != NULL_IDX) { 03267 if (IL_IDX(list_idx2) == attr_idx) { 03268 /* remove the attr from the list */ 03269 03270 if (list_idx2 == cdir_switches.bounds_il_list) { 03271 cdir_switches.bounds_il_list = 03272 IL_NEXT_LIST_IDX(list_idx2); 03273 if (cdir_switches.bounds_il_list) { 03274 IL_PREV_LIST_IDX( 03275 cdir_switches.bounds_il_list) = 03276 NULL_IDX; 03277 } 03278 } 03279 else { 03280 IL_NEXT_LIST_IDX(IL_PREV_LIST_IDX(list_idx2)) = 03281 IL_NEXT_LIST_IDX(list_idx2); 03282 if (IL_NEXT_LIST_IDX(list_idx2)) { 03283 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = 03284 IL_PREV_LIST_IDX(list_idx2); 03285 } 03286 } 03287 FREE_IR_LIST_NODE(list_idx2); 03288 03289 break; 03290 } 03291 list_idx2 = IL_NEXT_LIST_IDX(list_idx2); 03292 } 03293 } 03294 03295 /* now add to nobounds list if not already there */ 03296 03297 if (ATD_NOBOUNDS_CHECK(attr_idx) == FALSE) { 03298 ATD_NOBOUNDS_CHECK(attr_idx) = TRUE; 03299 03300 NTR_IR_LIST_TBL(list_idx2); 03301 IL_FLD(list_idx2) = AT_Tbl_Idx; 03302 IL_IDX(list_idx2) = attr_idx; 03303 03304 IL_NEXT_LIST_IDX(list_idx2) = 03305 cdir_switches.nobounds_il_list; 03306 IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2; 03307 cdir_switches.nobounds_il_list = list_idx2; 03308 } 03309 03310 list_idx1 = IL_NEXT_LIST_IDX(list_idx1); 03311 } 03312 } 03313 else { 03314 cdir_switches.bounds = FALSE; 03315 03316 /* clear the BOUNDS flag on all attrs in the nobounds list */ 03317 03318 list_idx1 = cdir_switches.bounds_il_list; 03319 cdir_switches.bounds_il_list = NULL_IDX; 03320 03321 while (list_idx1) { 03322 attr_idx = IL_IDX(list_idx1); 03323 ATD_BOUNDS_CHECK(attr_idx) = FALSE; 03324 03325 list_idx2 = list_idx1; 03326 list_idx1 = IL_NEXT_LIST_IDX(list_idx1); 03327 FREE_IR_LIST_NODE(list_idx2); 03328 } 03329 } 03330 break; 03331 03332 03333 case Entry_Opr : 03334 lastblkix = blkix; 03335 blkix = mifalloc[mtag_blk](&msp); 03336 msp.blk[blkix].pos = pos; 03337 msp.blk[blkix].scope = local_scope; 03338 if (VALID(lastblkix)) { 03339 mflow_local(&msp, lastblkix, blkix); 03340 } 03341 03342 mif_opn_add(&msp.blk[blkix], 03343 mop_entry, 03344 get_basic_type(NONE), 03345 pos, 03346 flags, 03347 mif_attr_map[IR_IDX_L(ir_idx)], 03348 mopd_null, 03349 mopd_null); 03350 break; 03351 03352 03353 03354 case Return_Opr : 03355 if (INVALID(blkix)) { 03356 blkix = mifalloc[mtag_blk](&msp); 03357 msp.blk[blkix].pos = pos; 03358 msp.blk[blkix].scope = local_scope; 03359 } 03360 03361 cvrt_exp_to_mif(&opd1, &msp.blk[blkix], 03362 IR_IDX_L(ir_idx), IR_FLD_L(ir_idx), 03363 flags, value); /* alt */ 03364 03365 cvrt_exp_to_mif(&opd0, &msp.blk[blkix], 03366 IR_IDX_R(ir_idx), IR_FLD_R(ir_idx), 03367 flags, value); /* value */ 03368 03369 mif_opn_add(&msp.blk[blkix], 03370 mop_return, 03371 get_basic_type(NONE), 03372 pos, 03373 flags, 03374 opd0, 03375 opd1, 03376 mopd_null); 03377 03378 blkix = NONE; 03379 break; 03380 03381 03382 03383 case Label_Opr : 03384 attr_idx = IR_IDX_L(ir_idx); 03385 if (ATL_CLASS(attr_idx) == Lbl_Format || 03386 ATL_CLASS(attr_idx) <= Lbl_User && 03387 !ATL_EXECUTABLE(attr_idx)) { 03388 break; 03389 } 03390 03391 mif_attr_map[attr_idx].val = cvrt_label(attr_idx, flags, pos); 03392 lastblkix = blkix; 03393 blkix = mif_attr_map[attr_idx].val; 03394 msp.blk[blkix].pos = pos; 03395 if (VALID(lastblkix)) { 03396 mflow_local(&msp, lastblkix, blkix); 03397 } 03398 break; 03399 03400 03401 case Suppress_Opr : 03402 attr_idx = IR_IDX_R(ir_idx); 03403 mif_attr_map[attr_idx].val = cvrt_label(attr_idx, flags, pos); 03404 lastblkix = blkix; 03405 blkix = mif_attr_map[attr_idx].val; 03406 msp.blk[blkix].pos = pos; 03407 if (VALID(lastblkix)) { 03408 mflow_local(&msp, lastblkix, blkix); 03409 } 03410 03411 /* Create as operands all variables referenced */ 03412 cvrt_exp_to_mif(&opd0, 03413 &msp.blk[blkix], 03414 IR_IDX_L(ir_idx), 03415 IR_FLD_L(ir_idx), 03416 flags, 03417 value); 03418 03419 mif_opn_add(&msp.blk[blkix], 03420 mop_supp, 03421 get_basic_type(NONE), 03422 pos, 03423 flags | 03424 mopnflag_precious | 03425 mopnflag_immobile | 03426 mopnflag_variant | 03427 mopnflag_distinct, 03428 opd0, mopd_null, mopd_null); 03429 break; 03430 03431 03432 case Br_Uncond_Opr : 03433 attr_idx = IR_IDX_R(ir_idx); 03434 mif_attr_map[attr_idx].val = cvrt_label(attr_idx, flags, mpos_null); 03435 if (INVALID(blkix)) { 03436 blkix = mifalloc[mtag_blk](&msp); 03437 msp.blk[blkix].pos = pos; 03438 msp.blk[blkix].scope = local_scope; 03439 } 03440 mflow_local(&msp, blkix, mif_attr_map[attr_idx].val); 03441 blkix = NONE; 03442 break; 03443 03444 03445 case Br_True_Opr : 03446 03447 attr_idx = IR_IDX_R(ir_idx); 03448 mif_attr_map[attr_idx].val = cvrt_label(attr_idx, flags, mpos_null); 03449 if (INVALID(blkix)) { 03450 blkix = mifalloc[mtag_blk](&msp); 03451 msp.blk[blkix].pos = pos; 03452 msp.blk[blkix].scope = local_scope; 03453 } 03454 03455 /* create mif for condition test */ 03456 cvrt_exp_to_mif(&opd0, &msp.blk[blkix], 03457 IR_IDX_L(ir_idx), IR_FLD_L(ir_idx), 03458 flags, value); 03459 /* add binary test to end of block */ 03460 mif_opn_add(&msp.blk[blkix], 03461 mop_if, 03462 get_basic_type(NONE), 03463 pos, 03464 flags, 03465 opd0, 03466 mopd_null, 03467 mopd_null); 03468 03469 lastblkix = blkix; 03470 blkix = mifalloc[mtag_blk](&msp); 03471 msp.blk[blkix].pos = pos; 03472 msp.blk[blkix].scope = local_scope; 03473 /* Make arc to false block */ 03474 mflow_local(&msp, lastblkix, blkix); 03475 /* Make arc to true block */ 03476 mflow_local(&msp, lastblkix, mif_attr_map[attr_idx].val); 03477 msp.blk[lastblkix].next = blkix; 03478 03479 break; 03480 03481 03482 case Br_Aif_Opr : 03483 03484 /* Make mif for equal label */ 03485 i= IR_IDX_R(ir_idx); /* label list */ 03486 attr_idx = IL_IDX(i); 03487 mif_attr_map[attr_idx].val = cvrt_label(attr_idx, flags, mpos_null); 03488 eq0 = mif_attr_map[attr_idx].val; 03489 03490 /* Make mif for greater than label */ 03491 i = IL_NEXT_LIST_IDX(i); 03492 attr_idx = IL_IDX(i); 03493 mif_attr_map[attr_idx].val = cvrt_label(attr_idx, flags, mpos_null); 03494 gt0 = mif_attr_map[attr_idx].val; 03495 03496 /* Make mif for less than label */ 03497 i = IL_NEXT_LIST_IDX(i); 03498 attr_idx = IL_IDX(i); 03499 mif_attr_map[attr_idx].val = cvrt_label(attr_idx, flags, mpos_null); 03500 lt0 = mif_attr_map[attr_idx].val; 03501 03502 if (INVALID(blkix)) { 03503 blkix = mifalloc[mtag_blk](&msp); 03504 msp.blk[blkix].pos = pos; 03505 msp.blk[blkix].scope = local_scope; 03506 } 03507 03508 cvrt_exp_to_mif(&opd0, 03509 &msp.blk[blkix], 03510 IR_IDX_L(ir_idx), 03511 IR_FLD_L(ir_idx), 03512 flags, 03513 value); 03514 03515 /* If all three targets identical - create unconditional branch. */ 03516 if (lt0 == eq0 && eq0 == gt0) { 03517 mif_opn_add(&msp.blk[blkix], 03518 mop_paren, 03519 mopdtype(&msp, opd0, msp.blk[blkix].opn), 03520 pos, 03521 flags, 03522 opd0, 03523 mopd_null, 03524 mopd_null); 03525 mflow_local(&msp, blkix, lt0); /* uncond */ 03526 blkix = NONE; 03527 break; 03528 } 03529 03530 /* If two targets identical - create normal conditional branch. */ 03531 if (lt0 == eq0 || lt0 == gt0 || eq0 == gt0) { 03532 03533 /* Get a zero of the right type */ 03534 typeix = mopdtype(&msp, opd0, msp.blk[blkix].opn); 03535 opd = mopd_0; 03536 if (typeix != msp.immtype) { 03537 opd = mif_opn_add(&msp.blk[blkix], mop_cast, 03538 typeix, pos, flags, 03539 opd, mopd_null, mopd_null); 03540 } 03541 03542 /* Turn into comparison against zero */ 03543 opd1 = mopd_0; 03544 if (lt0 == eq0) { 03545 opd1.val = mrelation_GT; 03546 } 03547 else if (lt0 == gt0) { 03548 opd1.val = mrelation_EQ; 03549 } 03550 else { 03551 opd1.val = mrelation_EQ | mrelation_GT; 03552 } 03553 03554 typ = *mtype_null[mtypeclass_bool]; 03555 typ.mbool.kind = storage_bit_kind_tbl[LOGICAL_DEFAULT_TYPE]; 03556 typ.mbool.size = mint(&msp, 03557 msp.immtype, 03558 (unsigned long) storage_bit_size_tbl[LOGICAL_DEFAULT_TYPE]); 03559 typ.mbool.prec = storage_bit_prec_tbl[LOGICAL_DEFAULT_TYPE]; 03560 03561 opd0 = mif_opn_add(&msp.blk[blkix], mop_cmp, 03562 mtype_lookup(&msp, &typ), 03563 pos, 03564 flags, 03565 opd0, 03566 opd, 03567 opd1); 03568 03569 mflow_local(&msp, blkix, lt0); /* F */ 03570 if (lt0 == eq0) { 03571 mflow_local(&msp, blkix, gt0); /* T */ 03572 } 03573 else { 03574 mflow_local(&msp, blkix, eq0); /* T */ 03575 } 03576 03577 op = mop_if; 03578 typeix = get_basic_type(NONE); 03579 } 03580 else { 03581 03582 /* 3-branch arithmetic IF */ 03583 op = mop_aif; 03584 03585 typeix = get_basic_type(NONE); 03586 mflow_local(&msp, blkix, lt0); 03587 mflow_local(&msp, blkix, eq0); 03588 mflow_local(&msp, blkix, gt0); 03589 03590 } 03591 03592 mif_opn_add(&msp.blk[blkix], 03593 op, 03594 typeix, 03595 pos, 03596 flags, 03597 opd0, 03598 mopd_null, 03599 mopd_null); 03600 03601 blkix = NONE; 03602 break; 03603 03604 03605 case Br_Asg_Opr : 03606 03607 if (INVALID(blkix)) { 03608 blkix = mifalloc[mtag_blk](&msp); 03609 msp.blk[blkix].pos = pos; 03610 msp.blk[blkix].scope = local_scope; 03611 } 03612 03613 cvrt_exp_to_mif(&opd0, &msp.blk[blkix], 03614 IR_IDX_L(ir_idx), IR_FLD_L(ir_idx), 03615 flags, value); 03616 /* create indirect jump operation */ 03617 (void) mif_opn_add(&msp.blk[blkix], 03618 mop_ijmp, 03619 get_basic_type(NONE), 03620 pos, 03621 flags, 03622 opd0, 03623 mopd_null, 03624 mopd_null); 03625 03626 /* create arc from indirect jump to all reachable labels. */ 03627 for (attr_idx = SCP_ASSIGN_LBL_CHAIN(curr_scp_idx); 03628 attr_idx != NULL_IDX; 03629 attr_idx = ATL_NEXT_ASG_LBL_IDX(attr_idx)) { 03630 mif_attr_map[attr_idx].val = 03631 cvrt_label(attr_idx, flags, mpos_null); 03632 mflow_local(&msp, blkix, mif_attr_map[attr_idx].val); 03633 } 03634 03635 blkix = NONE; 03636 break; 03637 03638 03639 case Br_Index_Opr : 03640 03641 if (INVALID(blkix)) { 03642 blkix = mifalloc[mtag_blk](&msp); 03643 msp.blk[blkix].pos = pos; 03644 msp.blk[blkix].scope = local_scope; 03645 } 03646 03647 /* fall-through case for default */ 03648 lastblkix = blkix; 03649 blkix = mifalloc[mtag_blk](&msp); 03650 msp.blk[blkix].pos = pos; 03651 msp.blk[blkix].scope = local_scope; 03652 msp.blk[lastblkix].next = blkix; 03653 03654 /* Build a sequence of 'list' operations, each carrying a */ 03655 /* 'case' value in opd[0] and a successor list index in opd[2]. */ 03656 opd0 = mopd_0; /* 'case' values */ 03657 opd1 = mopd_null; /* list link */ 03658 opd2 = mopd_0; /* successor list indices */ 03659 for (i = 0, j = IR_IDX_R(ir_idx); 03660 i < IR_LIST_CNT_R(ir_idx); 03661 i++, j = IL_NEXT_LIST_IDX(j)) { 03662 03663 attr_idx = IL_IDX(j); 03664 03665 mif_attr_map[attr_idx].val = 03666 cvrt_label(attr_idx, flags, mpos_null); 03667 03668 opd0.val = i + 1; 03669 opd2.val = mflow_local(&msp, lastblkix, 03670 mif_attr_map[attr_idx].val); 03671 03672 opd1 = mif_opn_add(&msp.blk[lastblkix], mop_list, 03673 mopdtype(&msp, opd0, msp.blk[lastblkix].opn), pos, 03674 flags, opd0, opd1, opd2); 03675 } 03676 03677 cvrt_exp_to_mif(&opd0, &msp.blk[lastblkix], 03678 IR_IDX_L(ir_idx), IR_FLD_L(ir_idx), 03679 flags, value); 03680 opd2.val = mflow_local(&msp, lastblkix, blkix); /* default */ 03681 03682 mif_opn_add(&msp.blk[lastblkix], 03683 mop_switch, 03684 get_basic_type(NONE), 03685 pos, 03686 flags, 03687 opd0, 03688 opd1, 03689 opd2); 03690 break; 03691 03692 03693 case Select_Opr : 03694 /* Create new basic block in control flow graph if not within one. */ 03695 03696 if (INVALID(blkix)) { 03697 blkix = mifalloc[mtag_blk](&msp); 03698 msp.blk[blkix].pos = pos; 03699 msp.blk[blkix].scope = local_scope; 03700 } 03701 03702 /* Flatten select statement to a switch. */ 03703 03704 /* Scan forward to locate CASEs. Skip over nested CASEs. */ 03705 opd = mopd_null; /* default case */ 03706 opd1 = mopd_null; /* list link */ 03707 opd2 = mopd_0; /* succ list index */ 03708 /* # of CASEs left */ 03709 case_ct = CN_INT_TO_C(IL_IDX(IR_IDX_R(ir_idx))); 03710 nested_case_ct = 0; 03711 for (tmp_sh = SH_NEXT_IDX(curr_sh); 03712 case_ct && tmp_sh != NULL_IDX; 03713 tmp_sh = SH_NEXT_IDX(tmp_sh)) { 03714 03715 if (SH_IR_IDX(tmp_sh) == NULL_IDX) { 03716 continue; 03717 } 03718 03719 if (IR_OPR(SH_IR_IDX(tmp_sh)) == Select_Opr) { 03720 /* nested SELECT CASE construct */ 03721 nested_case_ct += 03722 CN_INT_TO_C(IL_IDX(IR_IDX_R(SH_IR_IDX(tmp_sh)))); 03723 } 03724 03725 else if (IR_OPR(SH_IR_IDX(tmp_sh)) == Case_Opr) { 03726 03727 if (IR_IDX_L(SH_IR_IDX(tmp_sh)) == NULL_IDX) { 03728 /* Default case */ 03729 continue; 03730 } 03731 03732 if (nested_case_ct) { /* nested CASE; skip */ 03733 nested_case_ct--; 03734 } 03735 03736 else { /* CASE corresponds to current SELECT */ 03737 03738 case_ct--; 03739 03740 /* Allocate a basic block for the case now. */ 03741 i = mifalloc[mtag_blk](&msp); 03742 msp.blk[i].pos = pos; 03743 msp.blk[i].scope = local_scope; 03744 03745 /* Save the block index in the text. This is a little */ 03746 /* dubious, but we're just overwriting the line # field. */ 03747 IR_LINE_NUM_R(SH_IR_IDX(tmp_sh)) = i; 03748 03749 cvrt_exp_to_mif(&opd0, &msp.blk[blkix], 03750 IR_IDX_L(SH_IR_IDX(tmp_sh)), 03751 IR_FLD_L(SH_IR_IDX(tmp_sh)), 03752 flags, value); 03753 opd2.val = mflow_local(&msp, blkix, i); 03754 opd1 = mif_opn_add(&msp.blk[blkix], mop_list, 03755 mopdtype(&msp, opd0, msp.blk[blkix].opn), 03756 pos, flags, opd0, opd1, opd2); 03757 } 03758 } 03759 } 03760 03761 /* Selector */ 03762 cvrt_exp_to_mif(&opd0, 03763 &msp.blk[blkix], 03764 IR_IDX_L(ir_idx), 03765 IR_FLD_L(ir_idx), 03766 flags, value); 03767 03768 /* Explicit DEFAULT or implicit "break" label */ 03769 i = IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx)); 03770 if (IR_LIST_CNT_R(ir_idx) > 2) { 03771 i = IL_NEXT_LIST_IDX(i); 03772 } 03773 attr_idx = IL_IDX(i); 03774 mif_attr_map[attr_idx].val = cvrt_label(attr_idx, flags, mpos_null); 03775 03776 /* Default successor index. */ 03777 opd = mopd_0; 03778 opd.val = mflow_local(&msp, blkix, mif_attr_map[attr_idx].val); 03779 03780 mif_opn_add(&msp.blk[blkix], 03781 mop_switch, 03782 get_basic_type(NONE), 03783 pos, 03784 flags, 03785 opd0, 03786 opd1, 03787 opd); 03788 03789 blkix = NONE; 03790 03791 break; 03792 03793 03794 case Case_Opr : 03795 if (IR_IDX_L(ir_idx) == NULL_IDX) { 03796 /* Ignore default case */ 03797 break; 03798 } 03799 03800 /* Move to block allocated during SELECT processing. */ 03801 lastblkix = blkix; 03802 blkix = IR_LINE_NUM_R(ir_idx); 03803 msp.blk[blkix].pos = pos; 03804 if (VALID(lastblkix)) { 03805 mflow_local(&msp, lastblkix, blkix); 03806 } 03807 break; 03808 03809 03810 case Loop_Info_Opr : 03811 03812 /* BECKER - Hack code to be removed once frontend 03813 * clearly marks the end of a parallel loop. 03814 * 03815 * Need to recognize start and end of loop to correctly 03816 * mark boundaries of a tasked loop. 03817 */ 03818 idx = IR_IDX_R(ir_idx); 03819 idx = IL_NEXT_LIST_IDX(idx); 03820 idx = IL_IDX(idx); 03821 idx = IL_NEXT_LIST_IDX(idx); 03822 loop_end_label_idx = IL_IDX(idx); 03823 break; 03824 03825 03826 case Loop_End_Opr : 03827 break; 03828 03829 03830 case Init_Opr : 03831 03832 if (IR_FLD_L(ir_idx) == IR_Tbl_Idx && 03833 IR_OPR(IR_IDX_L(ir_idx)) == Implied_Do_Opr) { 03834 03835 /* Initialize constant output list */ 03836 data_value_idx = IR_IDX_R(ir_idx); 03837 data_values_consumed = 0; 03838 03839 cvrt_data_impl_do(IR_IDX_L(ir_idx), IR_FLD_L(ir_idx)); 03840 } 03841 else { 03842 03843 /* simple initializer prepared by s_data.c */ 03844 03845 initix = mifalloc[mtag_init](&msp); 03846 msp.init[initix].offset = fold_exp(IR_IDX_L(ir_idx), 03847 IR_FLD_L(ir_idx), 03848 &baseattr, 03849 &fldattr, 03850 &typeix); 03851 03852 i = IR_IDX_R(ir_idx); /* constant */ 03853 03854 cn_idx = IL_IDX(i); 03855 03856 switch (TYP_TYPE(CN_TYPE_IDX(cn_idx))) { 03857 03858 case Character : 03859 if ((IR_FLD_L(ir_idx) == IR_Tbl_Idx) && 03860 ((IR_OPR(IR_IDX_L(ir_idx)) == Substring_Opr) || 03861 (IR_OPR(IR_IDX_L(ir_idx)) == Whole_Substring_Opr))) { 03862 l_idx = IR_IDX_R(IR_IDX_L(ir_idx)); 03863 l_idx = IL_NEXT_LIST_IDX(l_idx); 03864 l_idx = IL_NEXT_LIST_IDX(l_idx); 03865 msp.init[initix].size = CN_INT_TO_C(IL_IDX(l_idx)) * 03866 CHAR_BIT; 03867 } 03868 else { 03869 msp.init[initix].size = 03870 CN_INT_TO_C(TYP_IDX(CN_TYPE_IDX(cn_idx))) * CHAR_BIT; 03871 } 03872 break; 03873 03874 case Typeless : 03875 msp.init[initix].size = TYP_BIT_LEN(CN_TYPE_IDX(cn_idx)); 03876 break; 03877 03878 default : 03879 if (msp.type[typeix].u.size.tag != mtag_imm) { 03880 t = mif_con_to_host_long(&msp, 03881 msp.type[typeix].u.size.val); 03882 } 03883 else { 03884 t = msp.type[typeix].u.size.val; 03885 } 03886 03887 msp.init[initix].size = t; 03888 break; 03889 } 03890 03891 cvrt_const((char *)&CN_CONST(cn_idx), 03892 CN_TYPE_IDX(cn_idx), 03893 ATD_TYPE_IDX(fldattr), 03894 &msp.init[initix].val); 03895 03896 i = IL_NEXT_LIST_IDX(i); /* rep count */ 03897 msp.init[initix].count = CN_INT_TO_C(IL_IDX(i)); 03898 03899 i = IL_NEXT_LIST_IDX(i); /* stride */ 03900 msp.init[initix].stride = CN_INT_TO_C(IL_IDX(i)); 03901 if (!msp.init[initix].stride) { 03902 msp.init[initix].stride = msp.init[initix].size; 03903 } 03904 03905 insert_init(initix, 03906 mif_attr_map[baseattr].tag, 03907 mif_attr_map[baseattr].val); 03908 } 03909 break; 03910 03911 03912 case Init_Reloc_Opr : 03913 initix = mifalloc[mtag_init](&msp); 03914 03915 if (msp.ldexpr == 0) { 03916 mifalloc[mtag_ldexpr](&msp); 03917 } 03918 03919 offset = fold_exp(IR_IDX_L(ir_idx), 03920 IR_FLD_L(ir_idx), 03921 &baseattr, &fldattr, &typeix); 03922 03923 # if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX)) 03924 loc_offset_idx = IL_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx))); 03925 03926 03927 COPY_OPND(opnd, IL_OPND(IR_IDX_R(ir_idx))); 03928 attr_idx = find_left_attr(&opnd); 03929 03930 # ifdef _DEBUG 03931 if (SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)) == NULL_IDX) { 03932 PRINTMSG(IR_LINE_NUM(ir_idx), 1049, Internal, 03933 IR_COL_NUM(ir_idx)); 03934 } 03935 # endif 03936 03937 offset1.idx = ATD_OFFSET_IDX(attr_idx); 03938 offset1.fld = ATD_OFFSET_FLD(attr_idx); 03939 result.idx = ATD_OFFSET_IDX(SB_FIRST_ATTR_IDX( 03940 ATD_STOR_BLK_IDX(attr_idx))); 03941 result.fld = ATD_OFFSET_FLD(SB_FIRST_ATTR_IDX( 03942 ATD_STOR_BLK_IDX(attr_idx))); 03943 03944 size_offset_binary_calc(&offset1, &result, Minus_Opr, &result); 03945 03946 offset1.idx = loc_offset_idx; 03947 offset1.fld = CN_Tbl_Idx; 03948 03949 size_offset_binary_calc(&offset1, &result, Plus_Opr, &result); 03950 03951 attr_idx = SB_FIRST_ATTR_IDX(ATD_STOR_BLK_IDX(attr_idx)); 03952 03953 OPND_FLD(opnd) = AT_Tbl_Idx; 03954 OPND_IDX(opnd) = attr_idx; 03955 OPND_LINE_NUM(opnd) = IR_LINE_NUM(ir_idx); 03956 OPND_COL_NUM(opnd) = IR_COL_NUM(ir_idx); 03957 03958 /* assumes there is a loc or aloc on top */ 03959 COPY_OPND(IR_OPND_L(IL_IDX(IR_IDX_R(ir_idx))), opnd); 03960 IR_OPR(IL_IDX(IR_IDX_R(ir_idx))) = Aloc_Opr; 03961 IR_TYPE_IDX(IL_IDX(IR_IDX_R(ir_idx))) = CRI_Ptr_8; 03962 03963 cvrt_exp_to_mif(&opd1, 03964 msp.ldexpr, 03965 IL_IDX(IR_IDX_R(ir_idx)), 03966 IL_FLD(IR_IDX_R(ir_idx)), 03967 flags, 03968 value); 03969 03970 char_bit.fld = CN_Tbl_Idx; 03971 char_bit.idx = CN_INTEGER_CHAR_BIT_IDX; 03972 03973 size_offset_binary_calc(&result, &char_bit, Div_Opr, &result); 03974 03975 # ifdef _TARGET32 03976 if (TYP_LINEAR(result.type_idx) == Integer_8) { 03977 result.constant[0] = result.constant[1]; 03978 result.type_idx = CG_INTEGER_DEFAULT_TYPE; 03979 result.fld = NO_Tbl_Idx; 03980 } 03981 # endif 03982 03983 if (result.fld == NO_Tbl_Idx) { 03984 cn_idx = ntr_const_tbl(result.type_idx, FALSE, result.constant); 03985 } 03986 else if (result.fld == CN_Tbl_Idx) { 03987 cn_idx = result.idx; 03988 } 03989 else { /* Should be constant here. */ 03990 PRINTMSG(IR_LINE_NUM(ir_idx), 1201, Internal, 03991 IR_COL_NUM(ir_idx), " "); 03992 } 03993 03994 cvrt_exp_to_mif(&opd2, 03995 msp.ldexpr, 03996 cn_idx, 03997 CN_Tbl_Idx, 03998 flags, 03999 value); 04000 04001 opd0 = mif_opn_add(msp.ldexpr, 04002 mop_pinc, 04003 mopdtype(&msp, opd1, msp.ldexpr->opn), 04004 mpos_null, 04005 0, 04006 opd1, 04007 opd2, 04008 mopd_null); 04009 # else 04010 cvrt_exp_to_mif(&opd0, 04011 msp.ldexpr, 04012 IL_IDX(IR_IDX_R(ir_idx)), 04013 IL_FLD(IR_IDX_R(ir_idx)), 04014 flags, 04015 value); 04016 # endif 04017 04018 msp.init[initix].val = opd0; 04019 msp.init[initix].offset = offset; 04020 msp.init[initix].count = 1; 04021 msp.init[initix].size = TARGET_BITS_PER_WORD; 04022 msp.init[initix].stride = msp.init[initix].size; 04023 04024 insert_init(initix, 04025 mif_attr_map[baseattr].tag, 04026 mif_attr_map[baseattr].val); 04027 break; 04028 04029 04030 04031 case Use_Opr: 04032 04033 # if defined(_MODULE_TO_DOT_o) 04034 04035 if (ATP_MOD_PATH_IDX(IR_IDX_L(ir_idx)) != NULL_IDX) { 04036 04037 if (INVALID(blkix)) { 04038 blkix = mifalloc[mtag_blk](&msp); 04039 msp.blk[blkix].pos = pos; 04040 msp.blk[blkix].scope = local_scope; 04041 } 04042 04043 length = ATP_MOD_PATH_LEN(IR_IDX_L(ir_idx)); 04044 04045 typ = *mtype_null[mtypeclass_raw]; 04046 typ.mraw.size = mint(&msp, 04047 msp.immtype, 04048 (unsigned long)(length * CHAR_BIT)); 04049 04050 opd0.tag = mtag_con; 04051 opd0.val = mcon_lookup(&msp, 04052 mtype_lookup(&msp, &typ), 04053 (char *)ATP_MOD_PATH_NAME_PTR(IR_IDX_L(ir_idx)), 04054 NONE); 04055 04056 length = ATP_EXT_NAME_LEN(IR_IDX_L(ir_idx)); 04057 04058 typ = *mtype_null[mtypeclass_raw]; 04059 typ.mraw.size = mint(&msp, 04060 msp.immtype, 04061 (unsigned long)(length * CHAR_BIT)); 04062 04063 opd1.tag = mtag_con; 04064 opd1.val = mcon_lookup(&msp, 04065 mtype_lookup(&msp, &typ), 04066 (char *)ATP_EXT_NAME_PTR(IR_IDX_L(ir_idx)), 04067 NONE); 04068 04069 mif_opn_add(&msp.blk[blkix], 04070 mop_usepath, 04071 get_basic_type(NONE), 04072 pos, 04073 flags, 04074 opd0, 04075 opd1, 04076 mopd_null); 04077 } 04078 # endif 04079 04080 break; 04081 04082 default: 04083 if (INVALID(blkix)) { 04084 blkix = mifalloc[mtag_blk](&msp); 04085 msp.blk[blkix].pos = pos; 04086 msp.blk[blkix].scope = local_scope; 04087 } 04088 04089 cvrt_exp_to_mif(&opd, 04090 &msp.blk[blkix], 04091 ir_idx, 04092 IR_Tbl_Idx, 04093 flags, 04094 address); 04095 break; 04096 } 04097 } 04098 } 04099 04100 TRACE (Func_Exit, "cvrt_ir_to_mif", NULL); 04101 04102 } /* cvrt_ir_to_mif */ 04103 04104 04105 04106 /******************************************************************************\ 04107 |* *| 04108 |* Description: *| 04109 |* Acquire intermediate form type table index for a frontend *| 04110 |* type entry. *| 04111 |* *| 04112 |* Input parameters: *| 04113 |* NONE *| 04114 |* *| 04115 |* Output parameters: *| 04116 |* NONE *| 04117 |* *| 04118 |* Returns: *| 04119 |* intermediate form type table index *| 04120 |* *| 04121 \******************************************************************************/ 04122 04123 static int get_basic_type(int type_idx) 04124 04125 { 04126 int idx; 04127 mtype_t typ; 04128 int btype; 04129 04130 TRACE (Func_Entry, "get_basic_type", NULL); 04131 04132 if (type_idx == NONE) { 04133 typ = *mtype_null[mtypeclass_void]; 04134 typ.mvoid.size = mint(&msp, msp.immtype, (unsigned long) 0); 04135 idx = mtype_lookup(&msp, &typ); 04136 } 04137 else { 04138 04139 switch (TYP_TYPE(type_idx)) { 04140 04141 case Typeless : 04142 typ = *mtype_null[mtypeclass_raw]; 04143 typ.mraw.size = mint(&msp, msp.immtype, 04144 (unsigned long) TYP_BIT_LEN(type_idx)); 04145 idx = mtype_lookup(&msp, &typ); 04146 break; 04147 04148 04149 case Integer : 04150 typ = *mtype_null[mtypeclass_int]; 04151 04152 switch (TYP_LINEAR(type_idx)) { 04153 case Integer_1: 04154 case Integer_2: 04155 case Integer_4: 04156 # ifdef _TARGET64 04157 if (unsigned_type) { 04158 typ.mint.flags |= mtypeflag_unsigned; 04159 } 04160 # endif 04161 break; 04162 } 04163 04164 typ.mint.kind = storage_bit_kind_tbl[TYP_LINEAR(type_idx)]; 04165 typ.mint.size = mint(&msp, msp.immtype, 04166 (unsigned long) storage_bit_size_tbl[TYP_LINEAR(type_idx)]); 04167 typ.mint.prec = storage_bit_prec_tbl[TYP_LINEAR(type_idx)]; 04168 idx = mtype_lookup(&msp, &typ); 04169 break; 04170 04171 04172 case Logical : 04173 typ = *mtype_null [mtypeclass_bool]; 04174 typ.mint.kind = storage_bit_kind_tbl[TYP_LINEAR(type_idx)]; 04175 typ.mint.size = mint(&msp, msp.immtype, 04176 (unsigned long) storage_bit_size_tbl[TYP_LINEAR(type_idx)]); 04177 typ.mint.prec = storage_bit_prec_tbl[TYP_LINEAR(type_idx)]; 04178 idx = mtype_lookup(&msp, &typ); 04179 break; 04180 04181 04182 case Real : 04183 typ = *mtype_null[mtypeclass_float]; 04184 typ.mint.kind = storage_bit_kind_tbl[TYP_LINEAR(type_idx)]; 04185 typ.mint.size = mint(&msp, msp.immtype, 04186 (unsigned long) storage_bit_size_tbl[TYP_LINEAR(type_idx)]); 04187 typ.mint.prec = storage_bit_prec_tbl[TYP_LINEAR(type_idx)]; 04188 idx = mtype_lookup(&msp, &typ); 04189 break; 04190 04191 04192 case Complex : 04193 typ = *mtype_null [mtypeclass_complex]; 04194 typ.mint.kind = storage_bit_kind_tbl[TYP_LINEAR(type_idx)]; 04195 typ.mint.size = mint(&msp, msp.immtype, 04196 (unsigned long) storage_bit_size_tbl[TYP_LINEAR(type_idx)]); 04197 typ.mint.prec = storage_bit_prec_tbl[TYP_LINEAR(type_idx)]; 04198 idx = mtype_lookup(&msp, &typ); 04199 break; 04200 04201 04202 case Character : 04203 typ = *mtype_null[mtypeclass_fchar]; 04204 typ.mfchar.prec = storage_bit_prec_tbl[TYP_LINEAR(type_idx)]; 04205 04206 switch (TYP_CHAR_CLASS(type_idx)) { 04207 case Assumed_Size_Char : 04208 case Var_Len_Char : 04209 typ.mfchar.temp.val = cvrt_attr_ntry(TYP_IDX(type_idx)); 04210 typ.mfchar.temp.tag = mif_attr_map[TYP_IDX(type_idx)].tag; 04211 break; 04212 04213 case Const_Len_Char : 04214 typ.mfchar.size = mint(&msp, msp.immtype, 04215 (unsigned long) (CHAR_BIT * CN_INT_TO_C(TYP_IDX(type_idx)))); 04216 break; 04217 } 04218 04219 idx = mtype_lookup(&msp, &typ); 04220 break; 04221 04222 04223 case Structure : 04224 idx = cvrt_derived_type(TYP_IDX(type_idx)); 04225 break; 04226 04227 04228 case CRI_Ptr : 04229 /* CRI Pointer has no base type */ 04230 /* since a pointer can have multiple */ 04231 /* pointees of different types. */ 04232 04233 typ = *mtype_null[mtypeclass_addr]; 04234 typ.maddr.size = mint(&msp, msp.immtype, 04235 (unsigned long) storage_bit_size_tbl[CRI_Ptr_8]); 04236 typ.maddr.prec = TYP_PTR_INCREMENT(type_idx); 04237 typ.maddr.aliasing = maliasclass_restrict; 04238 idx = mtype_lookup(&msp, &typ); 04239 break; 04240 04241 04242 case CRI_Ch_Ptr : 04243 /* base type of CRI char pointer is a CHARACTER *(*) */ 04244 04245 typ = *mtype_null[mtypeclass_fchar]; 04246 typ.mfchar.prec = CHAR_BIT; 04247 btype = mtype_lookup(&msp, &typ); 04248 04249 typ = *mtype_null[mtypeclass_addr]; 04250 typ.maddr.size = mint(&msp, msp.immtype, 04251 (unsigned long) storage_bit_size_tbl[CRI_Ch_Ptr_8]); 04252 typ.maddr.prec = storage_bit_prec_tbl[CRI_Ch_Ptr_8]; 04253 typ.maddr.base = btype; 04254 typ.maddr.aliasing = maliasclass_restrict; 04255 04256 idx = mtype_lookup(&msp, &typ); 04257 break; 04258 04259 04260 case CRI_Parcel_Ptr : 04261 typ = *mtype_null[mtypeclass_blkaddr]; 04262 typ.mblkaddr.size = mint(&msp, msp.immtype, 04263 (unsigned long) storage_bit_size_tbl[CRI_Parcel_Ptr_8]); 04264 idx = mtype_lookup(&msp, &typ); 04265 break; 04266 04267 04268 default : 04269 PRINTMSG(1, 1044, Internal, 0, "unexpected TYP_TYPE value"); 04270 04271 } /* End switch */ 04272 04273 } /* Else */ 04274 04275 TRACE (Func_Exit, "get_basic_type", NULL); 04276 04277 return(idx); 04278 04279 } /* get_basic_type */ 04280 04281 04282 04283 /******************************************************************************\ 04284 |* *| 04285 |* Description: *| 04286 |* Construct a pointer type for a given pointee type. *| 04287 |* *| 04288 |* Input parameters: *| 04289 |* Frontend type index *| 04290 |* *| 04291 |* Output parameters: *| 04292 |* NONE *| 04293 |* *| 04294 |* Returns: *| 04295 |* Index of created intermediate type *| 04296 |* *| 04297 \******************************************************************************/ 04298 static int get_ptr_type(fld_type field, 04299 int idx) 04300 { 04301 int typ_idx; 04302 mtype_t type; 04303 04304 04305 TRACE (Func_Exit, "get_ptr_type", NULL); 04306 04307 type = *mtype_null[mtypeclass_addr]; 04308 04309 if (field == AT_Tbl_Idx) { 04310 type.maddr.base = get_type_idx(idx); 04311 04312 if (AT_OBJ_CLASS(idx) == Data_Obj && 04313 (ATD_CLASS(idx) == Dummy_Argument || 04314 ATD_CLASS(idx) == Function_Result || 04315 ATD_CLASS(idx) == CRI__Pointee)) { 04316 type.maddr.aliasing = maliasclass_restrict; 04317 } 04318 else { 04319 type.maddr.aliasing = maliasclass_anytype; 04320 } 04321 } 04322 else if (field == IR_Tbl_Idx) { 04323 type.maddr.base = get_basic_type(IR_TYPE_IDX(idx)); 04324 04325 if (IR_OPR(idx) == Const_Tmp_Loc_Opr) { 04326 type.maddr.aliasing = maliasclass_restrict; 04327 } 04328 else { 04329 type.maddr.aliasing = maliasclass_anytype; 04330 } 04331 } 04332 04333 typ_idx = type.maddr.base; 04334 while (VALID(msp.type[typ_idx].u.base)) { 04335 typ_idx = msp.type[typ_idx].u.base; 04336 } 04337 04338 if (msp.type[typ_idx].u.class == mtypeclass_fchar) { 04339 type.maddr.size = mint(&msp, msp.immtype, 04340 (unsigned long) storage_bit_size_tbl[CRI_Ch_Ptr_8]); 04341 type.maddr.prec = storage_bit_prec_tbl[CRI_Ch_Ptr_8]; 04342 } 04343 else { 04344 type.maddr.size = mint(&msp, msp.immtype, 04345 (unsigned long) storage_bit_size_tbl[CRI_Ptr_8]); 04346 type.maddr.prec = storage_bit_prec_tbl[CRI_Ptr_8]; 04347 } 04348 04349 TRACE (Func_Exit, "get_ptr_type", NULL); 04350 04351 return(mtype_lookup(&msp, &type)); 04352 } /* get_ptr_type */ 04353 04354 04355 04356 /******************************************************************************\ 04357 |* *| 04358 |* Description: *| 04359 |* Construct an intermediate form type table entry for an attribute. *| 04360 |* *| 04361 |* Input parameters: *| 04362 |* attribute index *| 04363 |* *| 04364 |* Output parameters: *| 04365 |* NONE *| 04366 |* *| 04367 |* Returns: *| 04368 |* intermediate form type table index *| 04369 |* *| 04370 \******************************************************************************/ 04371 static int get_type_idx(int input_idx) 04372 { 04373 int array_idx; 04374 int attr_idx; 04375 int i; 04376 int j; 04377 int mtype; 04378 size_offset_type size; 04379 long temp; 04380 int tmp_idx; 04381 mtype_t typ; 04382 int type_idx; 04383 long val; 04384 04385 04386 TRACE (Func_Entry, "get_type_idx", NULL); 04387 04388 if (VALID(mif_attr_type_map[input_idx])) { 04389 /* If already translated, return translated value */ 04390 return(mif_attr_type_map[input_idx]); 04391 } 04392 04393 mtype = 0; 04394 04395 switch (AT_OBJ_CLASS(input_idx)) { 04396 04397 case Data_Obj: 04398 attr_idx = input_idx; 04399 04400 if (ATD_CLASS(attr_idx) == CRI__Pointee && 04401 TYP_TYPE(ATD_TYPE_IDX(ATD_PTR_IDX(attr_idx))) == CRI_Ch_Ptr) { 04402 /* Cray character pointee must be an assumed-length character */ 04403 typ = *mtype_null[mtypeclass_fchar]; 04404 typ.mfchar.prec = storage_bit_prec_tbl[CRI_Ch_Ptr_8]; 04405 typ.mfchar.temp.val = cvrt_attr_ntry(ATD_PTR_IDX(attr_idx)); 04406 typ.mfchar.temp.tag = mif_attr_map[ATD_PTR_IDX(attr_idx)].tag; 04407 04408 type_idx = mtype_lookup(&msp, &typ); 04409 } 04410 else { 04411 type_idx = get_basic_type(ATD_TYPE_IDX(attr_idx)); 04412 } 04413 break; 04414 04415 case Pgm_Unit: 04416 if (ATP_PGM_UNIT(input_idx) == Function) { 04417 attr_idx = ATP_RSLT_IDX(input_idx); 04418 04419 /* When a function result is an array or CHARACTER, the temps are */ 04420 /* just templates, never defined nor referenced in the IR. They */ 04421 /* still need to get to PDGCS. */ 04422 if (ATP_EXPL_ITRFC(input_idx) && !ATP_SCP_ALIVE(input_idx)) { 04423 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character && 04424 TYP_CHAR_CLASS(ATD_TYPE_IDX(attr_idx)) != Const_Len_Char) { 04425 cvrt_attr_ntry(TYP_IDX(ATD_TYPE_IDX(attr_idx))); 04426 } 04427 } 04428 04429 type_idx = get_basic_type(ATD_TYPE_IDX(attr_idx)); 04430 } 04431 else { 04432 type_idx = get_basic_type(NONE); 04433 goto EXIT; 04434 } 04435 break; 04436 04437 default: 04438 PRINTMSG(AT_DEF_LINE(input_idx), 450, Internal, 0, "get_type_idx"); 04439 break; 04440 04441 } /* End switch */ 04442 04443 /* Deferred_Shape and Assumed_Shape arrays will always be dope vectors. */ 04444 04445 if (ATD_IM_A_DOPE(attr_idx)) { /* Pointers */ 04446 04447 typ = *mtype_null [mtypeclass_dope]; 04448 typ.mdope.base = type_idx; 04449 typ.mdope.rank = (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) 04450 ? 0 04451 : BD_RANK(ATD_ARRAY_IDX(attr_idx)); 04452 typ.mdope.size = mint(&msp, msp.immtype, 04453 (unsigned long) (TARGET_BITS_PER_WORD * (6 + 3 * typ.mdope.rank))); 04454 type_idx = mtype_lookup(&msp, &typ); 04455 } 04456 04457 else if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 04458 04459 array_idx = ATD_ARRAY_IDX(attr_idx); 04460 04461 typ = *mtype_null[mtypeclass_array]; 04462 typ.marray.base = get_basic_type(ATD_TYPE_IDX(attr_idx)); 04463 typ.marray.rank = BD_RANK(array_idx); 04464 04465 if (typ.marray.rank) { 04466 04467 /* Allocate arrays of mif operands for array information */ 04468 04469 MEM_ALLOC(typ.marray.low, mopd_t, typ.marray.rank); 04470 MEM_ALLOC(typ.marray.stride, mopd_t, typ.marray.rank); 04471 MEM_ALLOC(typ.marray.extent, mopd_t, typ.marray.rank); 04472 } 04473 04474 if (BD_ARRAY_CLASS(array_idx) <= Assumed_Size) { 04475 size = stor_bit_size_of(attr_idx, FALSE, FALSE); 04476 04477 /* Size of one element*/ 04478 04479 if (size.fld == CN_Tbl_Idx) { 04480 typ.marray.size = mint(&msp, msp.immtype, 04481 (unsigned long) CN_INT_TO_C(size.idx)); 04482 } 04483 else { 04484 typ.marray.size = mint(&msp, msp.immtype, 04485 (unsigned long) CN_BIG_INT_TO_LONG(size)); 04486 } 04487 } 04488 04489 for (i = 1; i <= BD_RANK(array_idx); i++) { 04490 04491 /* Lower bound */ 04492 if (BD_LB_FLD(array_idx, i) == CN_Tbl_Idx) { 04493 cvrt_exp_to_mif(&typ.marray.low[i-1], 0, 04494 BD_LB_IDX(array_idx,i), CN_Tbl_Idx, 04495 mopnflag_syn, value); 04496 } 04497 else { 04498 j = BD_LB_IDX(array_idx, i); 04499 typ.marray.low[i-1].tag = mtag_lsym; 04500 typ.marray.low[i-1].val = cvrt_attr_ntry(j); 04501 } 04502 04503 /* Stride multiplier */ 04504 if (BD_SM_FLD(array_idx, i) == CN_Tbl_Idx) { 04505 cvrt_exp_to_mif(&typ.marray.stride[i-1], 0, 04506 BD_SM_IDX(array_idx,i), CN_Tbl_Idx, 04507 mopnflag_syn, value); 04508 } 04509 else { 04510 j = BD_SM_IDX(array_idx, i); 04511 typ.marray.stride[i-1].tag = mtag_lsym; 04512 typ.marray.stride[i-1].val = cvrt_attr_ntry(j); 04513 } 04514 04515 /* Extent */ 04516 if (BD_XT_FLD(array_idx, i) == CN_Tbl_Idx) { 04517 cvrt_exp_to_mif(&typ.marray.extent[i-1], 04518 0, 04519 BD_XT_IDX(array_idx,i), 04520 CN_Tbl_Idx, 04521 mopnflag_syn, 04522 value); 04523 04524 if (typ.marray.size.tag != mtag_imm) { 04525 temp = mif_con_to_host_long(&msp, typ.marray.size.val); 04526 } 04527 else { 04528 temp = typ.marray.size.val; 04529 } 04530 04531 typ.marray.size = mint(&msp, msp.immtype, 04532 (unsigned long) (temp * CN_INT_TO_C(BD_XT_IDX(array_idx, i)))); 04533 } 04534 else { 04535 j = BD_XT_IDX(array_idx, i); 04536 typ.marray.extent[i-1].tag = mtag_lsym; 04537 typ.marray.extent[i-1].val = cvrt_attr_ntry(j); 04538 typ.marray.size = mint(&msp, msp.immtype, (unsigned long) 0); 04539 } 04540 } 04541 04542 type_idx = mtype_lookup(&msp, &typ); 04543 } 04544 04545 EXIT: 04546 mif_attr_type_map[input_idx] = type_idx; 04547 return(type_idx); 04548 04549 TRACE (Func_Exit, "get_type_idx", NULL); 04550 } /* get_type_idx */ 04551 04552 04553 04554 /******************************************************************************\ 04555 |* *| 04556 |* Description: *| 04557 |* cvrt_dummy_procedure converts a dummy argument procedure into a *| 04558 |* symbol table entry of a pointer to a function. *| 04559 |* *| 04560 |* Input parameters: *| 04561 |* attr_idx -> Index of attr entry for dummy procedure *| 04562 |* *| 04563 |* Output parameters: *| 04564 |* NONE *| 04565 |* *| 04566 |* Returns: *| 04567 |* NOTHING *| 04568 |* *| 04569 \******************************************************************************/ 04570 static void cvrt_dummy_procedure(int attr_idx) 04571 04572 { 04573 mtype_t ftype, ptype; 04574 int symix; 04575 04576 TRACE (Func_Entry, "cvrt_dummy_procedure", NULL); 04577 04578 /* Build a prototype */ 04579 ftype = *mtype_null [mtypeclass_func]; 04580 ftype.mfunc.base = get_type_idx(attr_idx); 04581 ftype.mfunc.flags = mtypeflag_arg_mystery; 04582 ptype = *mtype_null[mtypeclass_addr]; 04583 ptype.maddr.size = mint(&msp, msp.immtype, (unsigned long) 04584 storage_bit_size_tbl[CRI_Ptr_8]); 04585 ptype.maddr.prec = storage_bit_prec_tbl[CRI_Ptr_8]; 04586 ptype.maddr.aliasing = maliasclass_restrict; 04587 ptype.maddr.base = mtype_lookup(&msp, &ftype); 04588 04589 symix = mifalloc[mtag_lsym](&msp); 04590 mif_attr_map[attr_idx].tag = mtag_lsym; 04591 mif_attr_map[attr_idx].val = symix; 04592 msp.lsym[symix].name = mnpool(&msp, AT_OBJ_NAME_PTR(attr_idx)); 04593 msp.lsym[symix].scope = local_scope; 04594 04595 /* Set flag if hosted stack is used */ 04596 if (AT_REF_IN_CHILD(attr_idx)) { 04597 msp.lsym[symix].flags |= msymflag_child_ref; 04598 } 04599 if (AT_DEF_IN_CHILD(attr_idx)) { 04600 msp.lsym[symix].flags |= msymflag_child_def; 04601 } 04602 if (AT_DEFINED(attr_idx)) { 04603 msp.lsym[symix].flags |= msymflag_modified; 04604 } 04605 msp.lsym[symix].storage = mstorage_formal; 04606 msp.lsym[symix].type = mtype_lookup(&msp, &ptype); 04607 04608 TRACE (Func_Exit, "cvrt_dummy_procedure", NULL); 04609 04610 } /* cvrt_dummy_procedure */ 04611 04612 04613 04614 04615 /******************************************************************************\ 04616 |* *| 04617 |* Description: *| 04618 |* cvrt_darg_list sends the dummy argument list for the given program. *| 04619 |* *| 04620 |* Input parameters: *| 04621 |* pgm_attr_idx -> Index of attr entry for program unit, whose *| 04622 |* dummy args need to be converted. *| 04623 |* *| 04624 |* Output parameters: *| 04625 |* NONE *| 04626 |* *| 04627 |* Returns: *| 04628 |* Secondary symbol table list first index *| 04629 |* *| 04630 \******************************************************************************/ 04631 static int cvrt_darg_list(int pgm_attr_idx) 04632 04633 { 04634 int i; 04635 int attr_idx; 04636 int size; 04637 int sn_idx; 04638 mtype_t ftype, ptype; 04639 msym_t *s; 04640 int symix = NONE; 04641 int sym2ix; 04642 int first_sym2_idx = NONE; 04643 int last_sym2_idx = NONE; 04644 04645 04646 TRACE (Func_Entry, "cvrt_darg_list", NULL); 04647 04648 for (i = 0; i < ATP_NUM_DARGS(pgm_attr_idx); i++) { 04649 04650 sn_idx = ATP_FIRST_IDX(pgm_attr_idx) + i; 04651 attr_idx = SN_ATTR_IDX(sn_idx); 04652 04653 if (!ATP_IN_INTERFACE_BLK(pgm_attr_idx)) { 04654 /* Get primary symbol table entry for dummy argument */ 04655 if (mif_attr_map[attr_idx].tag == mtag_none) { 04656 /* if not seen before, convert to mif */ 04657 04658 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 04659 cvrt_attr_ntry(attr_idx); 04660 } 04661 else { 04662 cvrt_dummy_procedure(attr_idx); 04663 } 04664 } 04665 04666 symix = mif_attr_map[attr_idx].val; 04667 } 04668 04669 /* Create secondary symbol table entry for dummy argument */ 04670 sym2ix = mifalloc[mtag_sym2](&msp); 04671 04672 if ((symix != NONE) && (msp.lsym[symix].flags & msymflag_implicit)) { 04673 msp.sym2[sym2ix].flags |= msym2flag_implicit; 04674 } 04675 04676 if (AT_OPTIONAL(attr_idx)) { 04677 msp.sym2[sym2ix].flags |= msym2flag_optional; 04678 } 04679 04680 msp.sym2[sym2ix].lang = mlang_F90; 04681 msp.sym2[sym2ix].name = mnpool(&msp, AT_OBJ_NAME_PTR(attr_idx)); 04682 04683 if (symix != NONE) { 04684 s = &msp.lsym[symix]; 04685 s->argsym2_ct += 1; 04686 04687 if (s->argsym2_ct == 1) { 04688 MEM_ALLOC(s->argsym2, int, s->argsym2_ct); 04689 } 04690 else { 04691 MEM_REALLOC(s->argsym2, int, s->argsym2_ct); 04692 } 04693 04694 s->argsym2[s->argsym2_ct-1] = sym2ix; 04695 04696 if (AT_OBJ_CLASS (attr_idx) == Data_Obj) { 04697 symix = msp.lsym[symix].base.val; 04698 } 04699 04700 msp.sym2[sym2ix].type = msp.lsym[symix].type; 04701 } 04702 else { 04703 /* Turn Fortran dummy arguments into based variables, pointees. */ 04704 msp.sym2[sym2ix].type = get_ptr_type(AT_Tbl_Idx, attr_idx); 04705 } 04706 04707 /* Note: sym2.base is filled in later by cvrt_proc */ 04708 04709 if (AT_OBJ_CLASS(attr_idx) == Data_Obj) { 04710 switch (ATD_INTENT(attr_idx)) { 04711 case Intent_In : 04712 msp.sym2[sym2ix].intent = mintent_in; 04713 break; 04714 case Intent_Out : 04715 msp.sym2[sym2ix].intent = mintent_out; 04716 break; 04717 default : 04718 if (ATD_CLASS(attr_idx) == Function_Result) { 04719 msp.sym2[sym2ix].intent = mintent_out; 04720 } 04721 else { 04722 msp.sym2[sym2ix].intent = mintent_in_out; 04723 } 04724 break; 04725 } 04726 } 04727 else /* Dummy procedure */ 04728 msp.sym2[sym2ix].intent = mintent_in_out; 04729 04730 if (VALID(last_sym2_idx)) { 04731 msp.sym2[last_sym2_idx].next = sym2ix; 04732 } 04733 else { 04734 first_sym2_idx = sym2ix; 04735 } 04736 last_sym2_idx = sym2ix; 04737 } 04738 04739 TRACE (Func_Exit, "cvrt_darg_list", NULL); 04740 04741 return(first_sym2_idx); 04742 04743 } /* cvrt_darg_list */ 04744 04745 04746 04747 04748 /******************************************************************************\ 04749 |* *| 04750 |* Description: *| 04751 |* Convert a procedure *| 04752 |* *| 04753 |* Input parameters: *| 04754 |* attr_idx -> Attr index of entry point. *| 04755 |* alt_entry_idx -> *| 04756 |* call_type -> This is an enum and can be a Definition, Parent or *| 04757 |* Imported. These determine which PDGCS inteface *| 04758 |* routine to call and what arguments need to be sent. *| 04759 |* *| 04760 |* Output parameters: *| 04761 |* NONE *| 04762 |* *| 04763 |* Returns: *| 04764 |* NOTHING *| 04765 |* *| 04766 \******************************************************************************/ 04767 static void cvrt_proc(int attr_idx, 04768 int alt_entry_idx, 04769 enum proc_call_class call_type) 04770 04771 { 04772 04773 int i; 04774 int pgm_unit; 04775 int funcix; 04776 mtype_t type; 04777 mtype_t typ; 04778 int proc; 04779 int main_entry_idx; 04780 char *p; 04781 int rslt_idx; 04782 int parent_attr; 04783 mpos_t pos; 04784 04785 04786 TRACE (Func_Entry, "cvrt_proc", NULL); 04787 04788 if (call_type == Imported) { 04789 /* Test to see if procedure needs to be converted */ 04790 04791 if (ATP_PROC(attr_idx) == Dummy_Proc) { 04792 if (mif_attr_map[attr_idx].tag == mtag_none) { 04793 /* if not seen before, convert to mif */ 04794 cvrt_dummy_procedure(attr_idx); 04795 } 04796 goto EXIT; 04797 } 04798 04799 if (ATP_PGM_UNIT(attr_idx) == Module && ATP_IN_CURRENT_COMPILE(attr_idx)){ 04800 /* Only need to convert modules that are not in the current */ 04801 /* compilation unit. */ 04802 goto EXIT; 04803 } 04804 else if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) { 04805 /* Don't convert anything else from a module; it's not needed. */ 04806 goto EXIT; 04807 } 04808 else if (AT_REFERENCED(attr_idx) == Not_Referenced && 04809 !ATP_DCL_EXTERNAL(attr_idx)) { 04810 /* Program units get converted only if they're referenced or */ 04811 /* declared EXTERNAL. We do send interfaces if they're not */ 04812 /* referenced, however. EXTERNAL items are immortal, as they */ 04813 /* are in CFT77. */ 04814 goto EXIT; 04815 } 04816 } 04817 04818 pgm_unit = ATP_PGM_UNIT(attr_idx); 04819 04820 /* Build a function table entry. */ 04821 if (mif_attr_map[attr_idx].tag != mtag_func) { 04822 mif_attr_map[attr_idx].tag = mtag_func; 04823 mif_attr_map[attr_idx].val = mifalloc[mtag_func](&msp); 04824 } 04825 04826 pos = mpos_null; 04827 pos.line = source_position(AT_DEF_LINE(attr_idx)); 04828 pos.src = srcix; 04829 pos.col = AT_DEF_COLUMN(attr_idx); 04830 04831 funcix = mif_attr_map[attr_idx].val; 04832 msp.func[funcix].lang = mlang_F90; 04833 msp.func[funcix].pos = pos; 04834 04835 /* Flags */ 04836 if (attr_idx == glb_tbl_idx[Buffer_In_Attr_Idx]) { 04837 msp.func[funcix].flags |= mfuncflag_buffer_in; 04838 } 04839 else if (attr_idx == glb_tbl_idx[Buffer_Out_Attr_Idx]) { 04840 msp.func[funcix].flags |= mfuncflag_buffer_out; 04841 } 04842 04843 if (AT_ACTUAL_ARG(attr_idx)) { 04844 msp.func[funcix].flags |= mfuncflag_passed; 04845 } 04846 04847 if (AT_REFERENCED(attr_idx) == Not_Referenced && 04848 ATP_DCL_EXTERNAL(attr_idx) && 04849 ATP_PGM_UNIT(attr_idx) == Pgm_Unknown) { 04850 msp.func[funcix].flag2s |= mfuncflag2_unknown; 04851 } 04852 04853 # if defined(_ACCEPT_CMD_k) 04854 04855 if (cmd_line_flags.solaris_profile) { 04856 msp.func[funcix].flags |= mfuncflag_flowtrace; 04857 } 04858 04859 # elif defined(_ACCEPT_FLOW) 04860 04861 if (cdir_switches.flow) { 04862 msp.func[funcix].flags |= mfuncflag_flowtrace; 04863 } 04864 # endif 04865 04866 if (ATP_PROC(attr_idx) == Intrin_Proc) { 04867 msp.func[funcix].flags |= mfuncflag_intrinsic; 04868 } 04869 04870 switch (pgm_unit) { 04871 case Module: 04872 msp.func[funcix].flags |= mfuncflag_module; 04873 break; 04874 04875 case Program: 04876 msp.func[funcix].flags |= mfuncflag_main; 04877 break; 04878 } 04879 04880 if (call_type == Definition) { 04881 msp.func[funcix].flags |= mfuncflag_defined; 04882 } 04883 04884 /* Names */ 04885 msp.func[funcix].name = mnpool(&msp, AT_OBJ_NAME_PTR(attr_idx)); 04886 if (ATP_PROC(attr_idx) == Intrin_Proc) { 04887 msp.func[funcix].genericname = 04888 mnpool(&msp, AT_OBJ_NAME_PTR(ATP_INTERFACE_IDX(attr_idx))); 04889 } 04890 if (ATP_EXT_NAME_IDX(attr_idx) != NULL_IDX && 04891 ATP_EXT_NAME_IDX(attr_idx) != AT_NAME_IDX(attr_idx)) { 04892 msp.func[funcix].extname = 04893 mnpool(&msp, &name_pool[ATP_EXT_NAME_IDX(attr_idx)].name_char); 04894 } 04895 04896 if ((ATP_PROC(attr_idx) == Module_Proc) || 04897 (ATP_PROC(attr_idx) == Intern_Proc)) { 04898 if (call_type == Definition) { 04899 parent_attr = SCP_ATTR_IDX(SCP_PARENT_IDX(curr_scp_idx)); 04900 msp.func[funcix].within = mif_attr_map[parent_attr].val; 04901 } 04902 else if (ATP_SCP_IDX(attr_idx) != NULL_IDX) { 04903 parent_attr = SCP_ATTR_IDX(SCP_PARENT_IDX(ATP_SCP_IDX(attr_idx))); 04904 msp.func[funcix].within = mif_attr_map[parent_attr].val; 04905 } 04906 } 04907 04908 if (ATP_SCP_IDX(attr_idx) != NULL_IDX && 04909 ATP_HAS_TASK_DIRS(SCP_ATTR_IDX(ATP_SCP_IDX(attr_idx)))) { 04910 msp.func[funcix].flags |= mfuncflag_hastaskdir; 04911 } 04912 04913 if (ATP_ALT_ENTRY(attr_idx)) { 04914 msp.func[funcix].primary = mif_attr_map[alt_entry_idx].val; 04915 } 04916 04917 /* Function result variable */ 04918 04919 if (!ATP_EXTRA_DARG(attr_idx) && 04920 (pgm_unit == Function || ATP_HAS_ALT_RETURN(attr_idx))) { 04921 04922 if (ATP_HAS_ALT_RETURN(attr_idx)) { 04923 rslt_idx = ATP_RSLT_IDX(attr_idx); 04924 pgm_unit = Function; 04925 } 04926 else { 04927 rslt_idx = ATP_RSLT_IDX(attr_idx); 04928 } 04929 04930 if (call_type == Definition || call_type == Parent && 04931 SB_HOSTED_STACK(ATD_STOR_BLK_IDX(rslt_idx))) { 04932 cvrt_attr_ntry(rslt_idx); 04933 } 04934 } 04935 04936 04937 /* Build a prototype */ 04938 type = *mtype_null [mtypeclass_func]; 04939 if (ATP_VFUNCTION(attr_idx)) { 04940 msp.func[funcix].flags |= mfuncflag_vfunc; 04941 } 04942 04943 if (ATP_NOSIDE_EFFECTS(attr_idx)) { 04944 msp.func[funcix].flags |= mfuncflag_pure; 04945 } 04946 04947 if (ATP_RECURSIVE(attr_idx)) { 04948 msp.func[funcix].flags |= mfuncflag_recursive; 04949 } 04950 04951 if (ATP_INLINE_ALWAYS(attr_idx)) { 04952 msp.func[funcix].flags |= mfuncflag_inline; 04953 } 04954 04955 if (ATP_INLINE_NEVER(attr_idx)) { 04956 msp.func[funcix].flags |= mfuncflag_noinline; 04957 } 04958 04959 if (on_off_flags.recursive && 04960 (ATP_PGM_UNIT(attr_idx) == Function || 04961 ATP_PGM_UNIT(attr_idx) == Subroutine)) { 04962 msp.func[funcix].flags |= mfuncflag_recursive; 04963 } 04964 04965 if (call_type == Definition && 04966 (opt_flags.over_index | 04967 ATP_HAS_OVER_INDEXING(SCP_ATTR_IDX(curr_scp_idx)))) { 04968 msp.func[funcix].flags |= mfuncflag_overindex; 04969 } 04970 04971 /* Determine return type */ 04972 if (pgm_unit == Function && !ATP_EXTRA_DARG(attr_idx)) { 04973 type.mfunc.base = get_type_idx(ATP_RSLT_IDX(attr_idx)); 04974 } 04975 else if (pgm_unit == Subroutine && ATP_HAS_ALT_RETURN(attr_idx)) { 04976 type.mfunc.base = get_basic_type(CG_INTEGER_DEFAULT_TYPE); 04977 } 04978 else { 04979 type.mfunc.base = get_basic_type(NONE); 04980 } 04981 04982 if (ATP_EXTRA_DARG(attr_idx)) { 04983 msp.func[funcix].flags |= mfuncflag_result_is_arg; 04984 } 04985 04986 if (ATP_ARGCHCK_CALL(attr_idx)) { 04987 msp.func[funcix].flags |= mfuncflag_has_dcheck_arg; 04988 } 04989 04990 if (pgm_unit == Subroutine || pgm_unit == Function) { 04991 if ((ATP_PROC(attr_idx) == Intrin_Proc) || 04992 ((call_type == Imported) && 04993 (!ATP_IN_INTERFACE_BLK(attr_idx)))) { 04994 type.mfunc.flags |= mtypeflag_arg_mystery; 04995 } 04996 else { 04997 type.mfunc.list = cvrt_darg_list(attr_idx); 04998 04999 } 05000 } 05001 05002 if (ATP_DCL_EXTERNAL(attr_idx) || 05003 (ATP_PGM_UNIT(attr_idx)==Module && 05004 (ATP_SCP_IDX(attr_idx)!=curr_scp_idx || 05005 !ATP_IN_CURRENT_COMPILE(attr_idx)))) { 05006 type.mfunc.flags |= mtypeflag_external; 05007 type.mfunc.flags |= mtypeflag_arg_mystery; 05008 } 05009 05010 msp.func[funcix].type = mtype_lookup(&msp, &type); 05011 05012 /* Establish back links from formal arguments to prototype */ 05013 for (i = type.mfunc.list; VALID(i); i = msp.sym2[i].next) { 05014 msp.sym2[i].base = msp.func[funcix].type; 05015 } 05016 05017 05018 /* Recursively convert alternate entry points. Set ATP_SCP_ALIVE so if */ 05019 /* there are any bounds temps, they will get the right storage block. */ 05020 if (alt_entry_idx != NULL_IDX && !ATP_ALT_ENTRY(attr_idx)) { 05021 main_entry_idx = attr_idx; 05022 while (alt_entry_idx != NULL_IDX) { 05023 attr_idx = AL_ATTR_IDX(alt_entry_idx); 05024 ATP_SCP_ALIVE(attr_idx) = TRUE; 05025 cvrt_proc(attr_idx, main_entry_idx, call_type); 05026 ATP_SCP_ALIVE(attr_idx) = FALSE; 05027 alt_entry_idx = AL_NEXT_IDX(alt_entry_idx); 05028 } 05029 } 05030 05031 05032 EXIT: 05033 TRACE (Func_Exit, "cvrt_proc", NULL); 05034 05035 } /* cvrt_proc */ 05036 05037 05038 05039 05040 /******************************************************************************\ 05041 |* *| 05042 |* Description: *| 05043 |* Construct an intermediate type table entry for a derived type. *| 05044 |* *| 05045 |* Input parameters: *| 05046 |* derived type attribute index *| 05047 |* *| 05048 |* Output parameters: *| 05049 |* NONE *| 05050 |* *| 05051 |* Returns: *| 05052 |* NOTHING *| 05053 |* *| 05054 \******************************************************************************/ 05055 static int cvrt_derived_type(int dt_attr_idx) 05056 05057 { 05058 mtype_t typ; 05059 int attr_idx; 05060 int dt_idx; 05061 int idx; 05062 int sn_idx; 05063 int type_idx; 05064 int sym2ix; 05065 int last_sym2_idx = NONE; 05066 05067 05068 TRACE (Func_Entry, "cvrt_derived_type", NULL); 05069 05070 while (AT_ATTR_LINK(dt_attr_idx) != NULL_IDX) { 05071 dt_attr_idx = AT_ATTR_LINK(dt_attr_idx); 05072 } 05073 05074 /* If type already defined, return mapped value */ 05075 if (mif_attr_map[dt_attr_idx].tag != mtag_none) { 05076 return(mif_attr_map[dt_attr_idx].val); 05077 } 05078 05079 /* Since aggregate may reference itself, need to allocate entry for 05080 ** aggregate up front, even though members are not yet defined. */ 05081 type_idx = mifalloc[mtag_type](&msp); 05082 mif_attr_map[dt_attr_idx].tag = mtag_type; 05083 mif_attr_map[dt_attr_idx].val = type_idx; 05084 msp.type[type_idx].maggr.class = mtypeclass_aggr; 05085 if (ATT_CHAR_SEQ(dt_attr_idx)) { 05086 typ = *mtype_null[mtypeclass_fchar]; 05087 typ.mfchar.size = mint(&msp, msp.immtype, (unsigned long) CHAR_BIT); 05088 typ.mfchar.prec = CHAR_BIT; 05089 msp.type[type_idx].maggr.base = mtype_lookup(&msp, &typ); 05090 } 05091 else { 05092 typ = *mtype_null[mtypeclass_raw]; 05093 typ.mraw.size = mint(&msp, msp.immtype, 05094 (unsigned long) TARGET_BITS_PER_WORD); 05095 msp.type[type_idx].maggr.base = mtype_lookup(&msp, &typ); 05096 } 05097 05098 if (ATT_SEQUENCE_SET(dt_attr_idx)) { 05099 /* SEQUENCE statement specified within aggregate. */ 05100 msp.type[type_idx].maggr.flags |= mtypeflag_sequence; 05101 } 05102 05103 /* JBL - range issue here */ 05104 05105 msp.type[type_idx].maggr.size = mint(&msp, msp.immtype, 05106 (unsigned long) CN_INT_TO_C(ATT_STRUCT_BIT_LEN_IDX(dt_attr_idx))); 05107 msp.type[type_idx].maggr.name = mnpool(&msp, AT_OBJ_NAME_PTR(dt_attr_idx)); 05108 05109 /* If the whole thing - all components is character and the whole thing is */ 05110 /* sequenced then it's all byte_aligned, otherwise it's word aligned. */ 05111 05112 /* walk all members of aggregate - put into sym2 table */ 05113 for (sn_idx = ATT_FIRST_CPNT_IDX(dt_attr_idx); 05114 sn_idx != NULL_IDX; 05115 sn_idx = SN_SIBLING_LINK(sn_idx)) { 05116 05117 attr_idx = SN_ATTR_IDX(sn_idx); 05118 05119 /* get a new sym2 entry */ 05120 sym2ix = mifalloc[mtag_sym2](&msp); 05121 mif_attr_map[attr_idx].tag = mtag_sym2; 05122 mif_attr_map[attr_idx].val = sym2ix; 05123 msp.sym2[sym2ix].name = mnpool(&msp, AT_OBJ_NAME_PTR(attr_idx)); 05124 05125 /* JBL - Range issue here, */ 05126 05127 # if defined(_DEBUG) 05128 05129 if (ATD_OFFSET_FLD(attr_idx) != CN_Tbl_Idx) { 05130 PRINTMSG(AT_DEF_LINE(attr_idx), 1201, Internal, 05131 AT_DEF_COLUMN(attr_idx), AT_OBJ_NAME_PTR(attr_idx)); 05132 } 05133 # endif 05134 05135 msp.sym2[sym2ix].offset = mint(&msp, msp.immtype, 05136 (unsigned long) CN_INT_TO_C(ATD_CPNT_OFFSET_IDX(attr_idx))); 05137 idx = get_type_idx(attr_idx); 05138 msp.sym2[sym2ix].type = idx; 05139 msp.sym2[sym2ix].base = type_idx; 05140 05141 if (VALID(last_sym2_idx)) { 05142 msp.sym2[last_sym2_idx].next = sym2ix; 05143 } 05144 else { 05145 /* have aggregate type reference first member */ 05146 msp.type[type_idx].maggr.list = sym2ix; 05147 } 05148 last_sym2_idx = sym2ix; 05149 05150 } /* for all members of aggregate */ 05151 05152 05153 TRACE (Func_Exit, "cvrt_derived_type", NULL); 05154 05155 return type_idx; 05156 05157 } /* cvrt_derived_type */ 05158 05159 05160 05161 05162 /******************************************************************************\ 05163 |* *| 05164 |* Description: *| 05165 |* Construct a basic block for a label. *| 05166 |* *| 05167 |* Input parameters: *| 05168 |* Label attribute index *| 05169 |* *| 05170 |* Output parameters: *| 05171 |* Basic block index *| 05172 |* *| 05173 |* Returns: *| 05174 |* NOTHING *| 05175 |* *| 05176 \******************************************************************************/ 05177 static int cvrt_label(int attr_idx, 05178 mopnflag_t flags, 05179 mpos_t pos) 05180 05181 { 05182 int blkix; 05183 int il_idx; 05184 mopd_t list, opd0, opd1, opd; 05185 int safevl_idx; 05186 mtype_t typ; 05187 int unroll_idx; 05188 05189 05190 TRACE (Func_Entry, "cvrt_label", NULL); 05191 05192 if (mif_attr_map[attr_idx].tag == mtag_none) { 05193 blkix = mifalloc[mtag_blk](&msp); 05194 msp.blk[blkix].scope = local_scope; 05195 msp.blk[blkix].dbgclass = ATL_DEBUG_CLASS(attr_idx); 05196 mif_attr_map[attr_idx].tag = mtag_blk; 05197 mif_attr_map[attr_idx].val = blkix; 05198 } 05199 else { 05200 blkix = mif_attr_map[attr_idx].val; 05201 } 05202 05203 if (cmd_line_flags.debug_lvl <= Debug_Lvl_1 || /* -ez -ed -G0 -G1 */ 05204 ATL_IN_ASSIGN(attr_idx)) { 05205 msp.blk[blkix].flags |= mblkflag_precious; 05206 } 05207 05208 if (ATL_ALIGN(attr_idx)) { 05209 msp.blk[blkix].flags |= mblkflag_alignblk; 05210 } 05211 05212 opd0.tag = mtag_imm; 05213 opd0.val = 0; 05214 05215 if (ATL_PREFERVECTOR(attr_idx)) opd0.val |= mloopflag_prefer_vector; 05216 if (ATL_NEXTSCALAR(attr_idx)) opd0.val |= mloopflag_nextscalar; 05217 if (ATL_IVDEP(attr_idx)) opd0.val |= mloopflag_ivdep; 05218 if (ATL_SPLIT(attr_idx)) opd0.val |= mloopflag_streamsplit; 05219 if (!ATL_BL(attr_idx)) opd0.val |= mloopflag_nobl; 05220 if (ATL_CNCALL(attr_idx)) opd0.val |= mloopflag_cncall; 05221 05222 /* ATL_UNROLL_DIR is set to the following criteria from PDGCS: */ 05223 /* mif uses !mloopflag_nounroll to set FEI_LABDEF_UNROLL. */ 05224 05225 /* fei_new_labdef(), opt_flags, FEI_LABDEF_UNROLL */ 05226 05227 /* Set this to TRUE if */ 05228 /* ( ( "-Ounroll2" is enabled ) */ 05229 /* OR ( ( there is a [NO]UNROLL directive for the label ) */ 05230 /* AND ( "-Ounroll1" is enabled ) ) */ 05231 05232 if (!ATL_UNROLL_DIR(attr_idx)) opd0.val |= mloopflag_nounroll; 05233 if (ATL_NORECURRENCE(attr_idx)) opd0.val |= mloopflag_noreduce; 05234 if (ATL_NOVSEARCH(attr_idx)) opd0.val |= mloopflag_novsearch; 05235 if (ATL_NOVECTOR(attr_idx)) opd0.val |= mloopflag_novector; 05236 if (ATL_NOTASK(attr_idx)) opd0.val |= mloopflag_notask; 05237 if (opt_flags.loopalign) opd0.val |= mloopflag_align; 05238 if (ATL_TOP_OF_LOOP(attr_idx)) opd0.val |= mloopflag_loopchk; 05239 if (ATL_PREFERTASK(attr_idx)) opd0.val |= mloopflag_prefer_task; 05240 05241 /* List contains directives in this order */ 05242 /* safevl, Unroll, mark name, maxcpus, cache bypass */ 05243 /* Only need safevl and unroll here. */ 05244 05245 safevl_idx = NULL_IDX; 05246 unroll_idx = NULL_IDX; 05247 05248 if (ATL_DIRECTIVE_LIST(attr_idx) != NULL_IDX) { 05249 il_idx = IL_IDX(ATL_DIRECTIVE_LIST(attr_idx)) + Safevl_Dir_Idx; 05250 05251 if (IL_FLD(il_idx) == CN_Tbl_Idx) { 05252 safevl_idx = IL_IDX(il_idx); 05253 } 05254 05255 il_idx = IL_IDX(ATL_DIRECTIVE_LIST(attr_idx)) + Unroll_Dir_Idx; 05256 05257 if (IL_FLD(il_idx) == CN_Tbl_Idx) { 05258 unroll_idx = IL_IDX(il_idx); 05259 } 05260 } 05261 05262 /* If at a definition of a label in the IR. */ 05263 05264 if (((pos.line != 0) && 05265 (ATL_TOP_OF_LOOP(attr_idx))) || 05266 05267 ((pos.line != 0) && 05268 (ATL_CLASS(attr_idx) == Lbl_User) && 05269 (!ATL_IN_ASSIGN(attr_idx)) && 05270 (ATL_EXECUTABLE(attr_idx)))) { 05271 05272 if (ATL_CLASS(attr_idx) == Lbl_Format || 05273 (ATL_CLASS(attr_idx) <= Lbl_User && !ATL_EXECUTABLE(attr_idx))) { 05274 /* Intentionally blank */ 05275 } 05276 else { 05277 list = mopd_null; 05278 if (ATL_UNROLL_DIR(attr_idx) || 05279 ATL_IVDEP(attr_idx) || 05280 ATL_SHORTLOOP(attr_idx) || 05281 ATL_SHORTLOOP128(attr_idx)) { 05282 05283 if (ATL_SHORTLOOP(attr_idx)) { 05284 opd.tag = mtag_imm; 05285 opd.val = 64; 05286 } 05287 else if (ATL_SHORTLOOP128(attr_idx)) { 05288 opd.tag = mtag_imm; 05289 opd.val = 128; 05290 } 05291 else { 05292 opd = mopd_null; 05293 } 05294 05295 list = mif_opn_add(&msp.blk[blkix], 05296 mop_list, 05297 mopdtype(&msp, opd, msp.blk[blkix].opn), 05298 pos, 05299 flags, 05300 opd, 05301 mopd_null, 05302 mopd_null); 05303 05304 if (ATL_IVDEP(attr_idx)) { 05305 opd.tag = mtag_imm; 05306 opd.val = CN_INT_TO_C(safevl_idx); 05307 } 05308 else { 05309 opd = mopd_null; 05310 } 05311 05312 list = mif_opn_add(&msp.blk[blkix], 05313 mop_list, 05314 mopdtype(&msp, opd, msp.blk[blkix].opn), 05315 pos, 05316 flags, 05317 opd, 05318 list, 05319 mopd_null); 05320 05321 if (ATL_UNROLL_DIR(attr_idx)) { 05322 opd.tag = mtag_imm; 05323 opd.val = CN_INT_TO_C(unroll_idx); 05324 } 05325 else { 05326 opd = mopd_null; 05327 } 05328 05329 list = mif_opn_add(&msp.blk[blkix], 05330 mop_list, 05331 mopdtype(&msp, opd, msp.blk[blkix].opn), 05332 pos, 05333 flags, 05334 opd, 05335 list, 05336 mopd_null); 05337 } 05338 05339 mif_opn_add(&msp.blk[blkix], 05340 mop_loopopt, 05341 get_basic_type(NONE), 05342 pos, 05343 flags, 05344 opd0, 05345 list, 05346 mopd_null); 05347 } 05348 } 05349 05350 /* BECKER - Hack code to be removed once frontend 05351 * clearly marks the end of a parallel loop. 05352 * 05353 * Code to end Doparallel or Doall tasking region. 05354 */ 05355 else if (!msp.blk[blkix].opn_ct) { 05356 /* First time blk encountered becuase not operations */ 05357 if (VALID(task_region_top) && 05358 parallel_loop_end_label_idx==attr_idx && 05359 (msp.taskreg[task_region_stk[task_region_top]].regionclass== 05360 mregionclass_doall || 05361 msp.taskreg[task_region_stk[task_region_top]].regionclass== 05362 mregionclass_loop)) { 05363 05364 opd0.tag = mtag_taskreg; 05365 opd0.val = task_region_stk[task_region_top--]; 05366 mif_opn_add(&msp.blk[blkix], 05367 mop_tregend, 05368 get_basic_type(NONE), 05369 pos, 05370 flags, opd0, 05371 mopd_null, 05372 mopd_null); 05373 05374 loop_tregend_blk_idx = blkix; 05375 loop_tregend_opn_idx = msp.blk[blkix].opn_ct-1; 05376 loop_region_idx = opd0.val; 05377 } 05378 } 05379 05380 msp.blk[blkix].name = mnpool(&msp, AT_OBJ_NAME_PTR(attr_idx)); 05381 05382 TRACE (Func_Exit, "cvrt_label", NULL); 05383 05384 return(mif_attr_map[attr_idx].val); 05385 05386 } /* cvrt_label */ 05387 05388 05389 05390 /******************************************************************************\ 05391 |* *| 05392 |* Description: *| 05393 |* Represent an attribute entry in the intermediate form. *| 05394 |* *| 05395 |* Input parameters: *| 05396 |* Attribute index *| 05397 |* *| 05398 |* Output parameters: *| 05399 |* NONE *| 05400 |* *| 05401 |* Returns: *| 05402 |* mapped value (also placed in global mif_attr_map array) *| 05403 |* *| 05404 \******************************************************************************/ 05405 static int cvrt_attr_ntry(int attr_idx) 05406 05407 { 05408 int array_idx; 05409 int child_idx; 05410 int class; 05411 long constant[2] = {0L, 0L}; 05412 long flags = 0; 05413 int i; 05414 int j; 05415 int ptr_idx = NULL_IDX; 05416 int sb_idx; 05417 int sn_idx; 05418 int const_idx; 05419 int symix; 05420 int sbsymix; 05421 int ptrsymix; 05422 mstorage_t container_storage; 05423 int local_sb_idx; 05424 int parent_idx; 05425 mtype_t type; 05426 int host_sb_idx = NULL_IDX; 05427 mtag_t sym_tag; 05428 msym_t sym = mgsym_null; 05429 mtype_t typ; 05430 mopd_t opd0; 05431 mpos_t pos; 05432 05433 TRACE (Func_Entry, "cvrt_attr_ntry", NULL); 05434 05435 /* If previously computed, return known value. */ 05436 if (mif_attr_map[attr_idx].tag != mtag_none) { 05437 return(mif_attr_map[attr_idx].val); 05438 } 05439 05440 child_idx = attr_idx; 05441 while (AT_ATTR_LINK(attr_idx) != NULL_IDX) { 05442 attr_idx = AT_ATTR_LINK(attr_idx); 05443 } 05444 05445 pos = mpos_null; 05446 pos.line = source_position(AT_DEF_LINE(attr_idx)); 05447 pos.src = srcix; 05448 pos.col = AT_DEF_COLUMN(attr_idx); 05449 sym.pos = pos; 05450 05451 05452 switch (AT_OBJ_CLASS(attr_idx)) { 05453 05454 case Data_Obj: 05455 05456 sym.fill = mfill_none; 05457 sym.align = TARGET_BITS_PER_WORD; 05458 sb_idx = ATD_STOR_BLK_IDX(attr_idx); 05459 05460 switch (ATD_CLASS(attr_idx)) { 05461 05462 case Atd_Unknown: 05463 case Variable: 05464 case Compiler_Tmp: 05465 if (ATD_AUTOMATIC(attr_idx)) { 05466 sym.storage = mstorage_auto; 05467 sym.base.tag = mtag_lsym; 05468 sym.base.val = cvrt_attr_ntry(ATD_AUTO_BASE_IDX(attr_idx)); 05469 sym_tag = mtag_lsym; 05470 } 05471 break; 05472 05473 case CRI__Pointee: 05474 sym.storage = mstorage_based; 05475 sym.base.val = cvrt_attr_ntry(ATD_PTR_IDX(attr_idx)); 05476 sym.base.tag = mif_attr_map[ATD_PTR_IDX(attr_idx)].tag; 05477 05478 sym_tag = mtag_lsym; 05479 05480 if (SB_BLK_TYPE(ATD_STOR_BLK_IDX(ATD_PTR_IDX(attr_idx))) == Static) { 05481 sym_tag = mtag_gsym; 05482 } 05483 break; 05484 05485 case Function_Result: 05486 sym.flags |= msymflag_funcresult; 05487 break; 05488 05489 case Constant: 05490 const_idx = ATD_CONST_IDX(attr_idx); 05491 05492 /* array OR aggregate constant */ 05493 if (ATD_FLD(attr_idx) == AT_Tbl_Idx) { 05494 cvrt_attr_ntry(const_idx); 05495 goto EXIT; 05496 } 05497 05498 symix = mifalloc[mtag_lsym](&msp); 05499 mif_attr_map[attr_idx].tag = mtag_lsym; 05500 mif_attr_map[attr_idx].val = symix; 05501 05502 if (! AT_COMPILER_GEND(attr_idx)) { 05503 sym.flags |= msymflag_user; 05504 } 05505 msp.lsym[symix] = sym; 05506 msp.lsym[symix].scope = local_scope; 05507 msp.lsym[symix].storage = mstorage_const; 05508 msp.lsym[symix].type = get_basic_type(ATD_TYPE_IDX(attr_idx)); 05509 05510 cvrt_exp_to_mif(&opd0, 05511 0, 05512 const_idx, 05513 CN_Tbl_Idx, 05514 mopnflag_syn, 05515 value); 05516 05517 msp.lsym[symix].offset = opd0; 05518 msp.lsym[symix].name = mnpool(&msp, AT_OBJ_NAME_PTR(attr_idx)); 05519 goto EXIT; 05520 05521 } /* end switch */ 05522 05523 05524 /* Type */ 05525 sym.type = get_type_idx(attr_idx); 05526 05527 /* Offset */ 05528 05529 /* JBL - Range issue here. */ 05530 05531 if (ATD_OFFSET_ASSIGNED(attr_idx)) { 05532 05533 # if defined(_DEBUG) 05534 05535 if (ATD_OFFSET_FLD(attr_idx) != CN_Tbl_Idx) { 05536 PRINTMSG(AT_DEF_LINE(attr_idx), 1201, Internal, 05537 AT_DEF_COLUMN(attr_idx), AT_OBJ_NAME_PTR(attr_idx)); 05538 } 05539 # endif 05540 sym.offset = mint(&msp, 05541 msp.immtype, 05542 (unsigned long) CN_INT_TO_C(ATD_OFFSET_IDX(attr_idx))); 05543 05544 # if 0 05545 /* JBL .. I pulled this */ 05546 05547 sym.offset.tag = mtag_con; 05548 sym.offset.val = mcon_lookup(&msp, 05549 get_basic_type(CN_TYPE_IDX( 05550 ATD_OFFSET_IDX(attr_idx))), 05551 (char *)&CN_CONST(ATD_OFFSET_IDX(attr_idx)), 05552 NONE); 05553 # endif 05554 } 05555 05556 /* Storage block (if necessary) */ 05557 if ((sym.storage == mstorage_none) && (sym.base.tag == mtag_none)) { 05558 flags = 0; 05559 container_storage = mstorage_none; 05560 sym.storage = mstorage_member; 05561 05562 switch (SB_BLK_TYPE(sb_idx)) { 05563 case Static : 05564 sym_tag = mtag_gsym; 05565 if (SB_MODULE(sb_idx)) { 05566 container_storage = mstorage_module; 05567 } 05568 else { 05569 /* Frontend places static data in a specially created common */ 05570 /* block so that nested procedures can access it. */ 05571 container_storage = mstorage_common; 05572 } 05573 break; 05574 case Stack : 05575 case Non_Local_Stack : 05576 sym_tag = mtag_lsym; 05577 sym.storage = mstorage_stack; 05578 break; 05579 case Formal : 05580 case Non_Local_Formal : 05581 sym_tag = mtag_lsym; 05582 sym.storage = mstorage_formal; 05583 break; 05584 case Based : 05585 sym_tag = mtag_lsym; 05586 sym.storage = mstorage_based; 05587 break; 05588 case Static_Local : 05589 case Static_Named : 05590 sym_tag = mtag_gsym; 05591 container_storage = mstorage_static; 05592 sym.scope = local_scope; 05593 break; 05594 case Common : 05595 sym_tag = mtag_gsym; 05596 container_storage = mstorage_common; 05597 break; 05598 case Extern : 05599 sym_tag = mtag_gsym; 05600 container_storage = mstorage_extern; 05601 break; 05602 case Exported : 05603 sym_tag = mtag_gsym; 05604 container_storage = mstorage_exported; 05605 break; 05606 case Task_Common : 05607 sym_tag = mtag_gsym; 05608 container_storage = mstorage_taskcommon; 05609 break; 05610 case Soft_External : 05611 sym_tag = mtag_gsym; 05612 container_storage = mstorage_soft; 05613 break; 05614 case Equivalenced : 05615 sym_tag = mtag_lsym; 05616 container_storage = mstorage_equiv; 05617 break; 05618 default : 05619 PRINTMSG(1, 1044, Internal, 0, "unexpected storage block class"); 05620 } 05621 05622 05623 if (SB_SCP_IDX(sb_idx) != curr_scp_idx) { 05624 05625 if ((!SB_HOSTED_STACK(sb_idx)) && 05626 (SB_BLK_TYPE(sb_idx) != Formal) && 05627 (INVALID(mif_stor_blk_map[sb_idx]))) { 05628 05629 local_sb_idx = srch_stor_blk_tbl(SB_NAME_PTR(sb_idx), 05630 SB_NAME_LEN(sb_idx), 05631 curr_scp_idx); 05632 05633 if (VALID(mif_stor_blk_map[local_sb_idx])) { 05634 mif_stor_blk_map[sb_idx] = mif_stor_blk_map[local_sb_idx]; 05635 } 05636 else { 05637 host_sb_idx = sb_idx; 05638 sb_idx = local_sb_idx; 05639 } 05640 } 05641 } 05642 05643 if ((sym.storage == mstorage_member) && 05644 (sym.base.tag == mtag_none) && 05645 (container_storage != mstorage_none)) { 05646 05647 if (INVALID(mif_stor_blk_map[sb_idx])) { 05648 05649 if (sym_tag == mtag_gsym) { 05650 sbsymix = mifalloc[mtag_gsym](&msp); 05651 if (container_storage == mstorage_static) { 05652 msp.gsym[sbsymix].scope = local_scope; 05653 } 05654 } 05655 else { 05656 sbsymix = mifalloc[mtag_lsym](&msp); 05657 if ((AT_HOST_ASSOCIATED(attr_idx)) || 05658 (mif_attr_map[SCP_ATTR_IDX(SB_SCP_IDX(sb_idx))].val != 05659 msp.deffunc)) { 05660 msp.lsym[sbsymix].scope = host_scope; 05661 } 05662 else { 05663 msp.lsym[sbsymix].scope = local_scope; 05664 } 05665 } 05666 05667 /* Create another symbol for the storage block. */ 05668 mif_stor_blk_map[sb_idx] = sbsymix; 05669 if (host_sb_idx != NULL_IDX) { 05670 mif_stor_blk_map[host_sb_idx] = sbsymix; 05671 } 05672 05673 if (SB_BLK_TYPE(sb_idx) == Common) { 05674 flags |= msymflag_user_common; 05675 } 05676 05677 if (SB_SAVED(sb_idx)) { 05678 flags |= msymflag_save; 05679 } 05680 05681 if (SB_HOSTED_STACK(sb_idx)) { 05682 flags |= msymflag_child_ref | msymflag_child_def; 05683 } 05684 05685 /* JBL - Range issue here */ 05686 05687 # if defined(_DEBUG) 05688 05689 if (SB_LEN_FLD(sb_idx) != CN_Tbl_Idx) { 05690 PRINTMSG(SB_DEF_LINE(sb_idx), 1201, Internal, 05691 SB_DEF_COLUMN(sb_idx), 05692 SB_NAME_PTR(sb_idx)); 05693 } 05694 # endif 05695 05696 type = *mtype_null[mtypeclass_raw]; 05697 type.mraw.size = mint(&msp, 05698 msp.immtype, 05699 (unsigned long) (CN_INT_TO_C(SB_LEN_IDX(sb_idx)))); 05700 05701 if (sym_tag == mtag_gsym) { 05702 msp.gsym[sbsymix].flags = flags; 05703 msp.gsym[sbsymix].name = mnpool(&msp, SB_NAME_PTR(sb_idx)); 05704 msp.gsym[sbsymix].storage = container_storage; 05705 msp.gsym[sbsymix].type = mtype_lookup(&msp, &type); 05706 } 05707 else { 05708 msp.lsym[sbsymix].flags = flags; 05709 msp.lsym[sbsymix].name = mnpool(&msp, SB_NAME_PTR(sb_idx)); 05710 msp.lsym[sbsymix].storage = container_storage; 05711 msp.lsym[sbsymix].type = mtype_lookup(&msp, &type); 05712 } 05713 } 05714 05715 sym.base.tag = sym_tag; 05716 sym.base.val = mif_stor_blk_map[sb_idx]; 05717 } 05718 05719 if (sym.storage == mstorage_formal) { 05720 /* Turn Fortran dummy arguments into based variables, pointees */ 05721 /* of new restricted pointers that will be the actual formal */ 05722 /* arguments. This translation permits the intermediate */ 05723 /* language to have a uniform representation of arguments as */ 05724 /* a pass-by-value convention. */ 05725 05726 ptrsymix = mifalloc[mtag_lsym](&msp); 05727 msp.lsym[ptrsymix].storage = mstorage_formal; 05728 msp.lsym[ptrsymix].type = get_ptr_type(AT_Tbl_Idx, attr_idx); 05729 msp.lsym[ptrsymix].name = mnpool(&msp, AT_OBJ_NAME_PTR(attr_idx)); 05730 if (AT_REF_IN_CHILD(attr_idx)) { 05731 msp.lsym[ptrsymix].flags |= msymflag_child_ref; 05732 } 05733 if (AT_DEF_IN_CHILD(attr_idx)) { 05734 msp.lsym[ptrsymix].flags |= msymflag_child_def; 05735 } 05736 05737 sym.storage = mstorage_based; 05738 sym.base.tag = mtag_lsym; 05739 sym.base.val = ptrsymix; 05740 05741 if ((AT_HOST_ASSOCIATED(attr_idx)) || 05742 (mif_attr_map[SCP_ATTR_IDX(SB_SCP_IDX(sb_idx))].val != 05743 msp.deffunc)) { 05744 msp.lsym[ptrsymix].scope = host_scope; 05745 } 05746 else { 05747 msp.lsym[ptrsymix].scope = local_scope; 05748 } 05749 05750 /* This block of code updates the scopes of the */ 05751 /* temps for character lengths. If the variable */ 05752 /* is not referenced in a nested scope, the */ 05753 /* scope of the temps may not be correct. This */ 05754 /* code assures they are correct. */ 05755 if (TYP_FLD(ATD_TYPE_IDX(attr_idx)) == AT_Tbl_Idx) { 05756 j = TYP_IDX(ATD_TYPE_IDX(attr_idx)); 05757 if (mif_attr_map[j].tag == mtag_lsym) { 05758 msp.lsym[mif_attr_map[j].val].scope = 05759 msp.lsym[ptrsymix].scope; 05760 } 05761 else if (mif_attr_map[j].tag == mtag_gsym) { 05762 msp.gsym[mif_attr_map[j].val].scope = 05763 msp.lsym[ptrsymix].scope; 05764 } 05765 } 05766 05767 /* This block of code update the scopes of the */ 05768 /* temps created for arrays. If the array */ 05769 /* is not referenced in a nested scope, the */ 05770 /* scope of the temps may not be correct. This */ 05771 /* code assures they are correct. */ 05772 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 05773 array_idx = ATD_ARRAY_IDX(attr_idx); 05774 for (i = 1; i <= BD_RANK(array_idx); i++) { 05775 if (BD_XT_FLD(array_idx, i) == AT_Tbl_Idx) { 05776 j = BD_XT_IDX(array_idx, i); 05777 if (mif_attr_map[j].tag == mtag_lsym) { 05778 msp.lsym[mif_attr_map[j].val].scope = 05779 msp.lsym[ptrsymix].scope; 05780 } 05781 else if (mif_attr_map[j].tag == mtag_gsym) { 05782 msp.gsym[mif_attr_map[j].val].scope = 05783 msp.lsym[ptrsymix].scope; 05784 } 05785 } 05786 05787 if (BD_SM_FLD(array_idx, i) == AT_Tbl_Idx) { 05788 j = BD_SM_IDX(array_idx, i); 05789 if (mif_attr_map[j].tag == mtag_lsym) { 05790 msp.lsym[mif_attr_map[j].val].scope = 05791 msp.lsym[ptrsymix].scope; 05792 } 05793 else if (mif_attr_map[j].tag == mtag_gsym) { 05794 msp.gsym[mif_attr_map[j].val].scope = 05795 msp.lsym[ptrsymix].scope; 05796 } 05797 } 05798 05799 if (BD_LB_FLD(array_idx, i) == AT_Tbl_Idx) { 05800 j = BD_LB_IDX(array_idx, i); 05801 if (mif_attr_map[j].tag == mtag_lsym) { 05802 msp.lsym[mif_attr_map[j].val].scope = 05803 msp.lsym[ptrsymix].scope; 05804 } 05805 else if (mif_attr_map[j].tag == mtag_gsym) { 05806 msp.gsym[mif_attr_map[j].val].scope = 05807 msp.lsym[ptrsymix].scope; 05808 } 05809 } 05810 } 05811 } 05812 } 05813 } 05814 05815 05816 /* Alignment */ 05817 if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) { 05818 if ((ATD_IN_COMMON(attr_idx)) || 05819 (ATD_CLASS(attr_idx) == Struct_Component) || 05820 (ATD_CLASS(attr_idx) == Function_Result)) { 05821 sym.align = CHAR_BIT; 05822 } 05823 else if (ATD_CLASS(attr_idx) == Function_Result && 05824 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure) { 05825 sym.align = (ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) 05826 ? CHAR_BIT 05827 : TARGET_BITS_PER_WORD; 05828 } 05829 } 05830 else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == CRI_Ch_Ptr) { 05831 sym.align = storage_bit_size_tbl[CRI_Ch_Ptr_8]; 05832 } 05833 05834 05835 /* I/O type code */ 05836 if (ATD_CLASS(attr_idx) == Variable || 05837 ATD_CLASS(attr_idx) == Compiler_Tmp || 05838 ATD_CLASS(attr_idx) == Dummy_Argument || 05839 ATD_CLASS(attr_idx) == Function_Result || 05840 ATD_CLASS(attr_idx) == CRI__Pointee) { 05841 05842 make_io_type_code(ATD_TYPE_IDX(attr_idx), constant); 05843 05844 typ = *mtype_null[mtypeclass_raw]; 05845 typ.mraw.size = mint(&msp, 05846 msp.immtype, 05847 (unsigned long)TARGET_BITS_PER_WORD); 05848 05849 sym.IOcode = mcon_lookup(&msp, 05850 mtype_lookup(&msp, &typ), 05851 (char *)constant, 05852 NONE); 05853 } 05854 05855 05856 /* Flags */ 05857 if (ATD_CLASS(attr_idx) == Compiler_Tmp || 05858 ATD_CLASS(attr_idx) == Variable) { 05859 sym.flags |= msymflag_addrtaken; 05860 } 05861 05862 if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) { 05863 if (BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Assumed_Shape) { 05864 sym.flags |= msymflag_assumed_shape; 05865 } 05866 } 05867 05868 if (ATD_SYMMETRIC(attr_idx)) sym.flags |= msymflag_symmetric; 05869 if (ATD_POINTER(attr_idx)) sym.flags |= msymflag_pointer; 05870 if (ATD_AUXILIARY(attr_idx)) sym.flags |= msymflag_auxstore; 05871 if (ATD_TARGET(attr_idx)) sym.flags |= msymflag_target; 05872 if (ATD_EQUIV(attr_idx)) sym.flags |= msymflag_equiv; 05873 if (ATD_ALLOCATABLE(attr_idx)) sym.flags |= msymflag_allocatable; 05874 if (ATD_PERMUTATION(attr_idx)) sym.flags |= msymflag_permuted; 05875 if (ATD_SAVED(attr_idx)) sym.flags |= msymflag_save; 05876 if (AT_DEFINED(attr_idx)) sym.flags |= msymflag_modified; 05877 if (ATD_CLASS(attr_idx) != Compiler_Tmp)sym.flags |= msymflag_user; 05878 if (AT_REF_IN_CHILD(attr_idx)) sym.flags |= msymflag_child_ref; 05879 if (AT_DEF_IN_CHILD(attr_idx)) sym.flags |= msymflag_child_def; 05880 05881 sym.name = mnpool(&msp, AT_OBJ_NAME_PTR(attr_idx)); 05882 05883 symix = mifalloc[sym_tag](&msp); 05884 mif_attr_map[attr_idx].tag = sym_tag; 05885 mif_attr_map[attr_idx].val = symix; 05886 if (sym_tag == mtag_gsym) { 05887 msp.gsym[symix] = sym; 05888 } 05889 else { 05890 if ((AT_HOST_ASSOCIATED(attr_idx)) || 05891 (mif_attr_map[SCP_ATTR_IDX(SB_SCP_IDX(sb_idx))].val != 05892 msp.deffunc)) { 05893 sym.scope = host_scope; 05894 } 05895 else { 05896 sym.scope = local_scope; 05897 } 05898 05899 msp.lsym[symix] = sym; 05900 } 05901 05902 break; 05903 05904 05905 case Pgm_Unit: 05906 if (mif_attr_map[attr_idx].tag != mtag_func) { 05907 cvrt_proc(attr_idx, NULL_IDX, Imported); 05908 } 05909 break; 05910 05911 05912 case Label: 05913 cvrt_label(attr_idx, 0, mpos_null); 05914 break; 05915 05916 05917 case Interface: 05918 05919 if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Module) { 05920 05921 /* This is an interface block that has the same name as one of */ 05922 /* its program units. The program unit has to go through the */ 05923 /* interface. */ 05924 if (ATI_PROC_IDX(attr_idx) != NULL_IDX) { 05925 cvrt_attr_ntry(ATI_PROC_IDX(attr_idx)); 05926 } 05927 05928 /* Establish the generic name of the routines */ 05929 sn_idx = ATI_FIRST_SPECIFIC_IDX(attr_idx); 05930 for (i = 0; i < ATI_NUM_SPECIFICS(attr_idx); i++) { 05931 if (SN_ATTR_IDX(sn_idx) != NULL_IDX) { 05932 cvrt_attr_ntry(SN_ATTR_IDX(sn_idx)); 05933 05934 /* don't copy name unless proc was actually sent */ 05935 if (mif_attr_map[SN_ATTR_IDX(sn_idx)].tag != mtag_none) { 05936 msp.func[mif_attr_map[SN_ATTR_IDX(sn_idx)].val].genericname = 05937 mnpool(&msp, AT_OBJ_NAME_PTR(attr_idx)); 05938 } 05939 } 05940 sn_idx = SN_SIBLING_LINK(sn_idx); 05941 } 05942 } 05943 break; 05944 05945 05946 case Derived_Type: 05947 cvrt_derived_type(attr_idx); 05948 break; 05949 05950 05951 } /* End switch */ 05952 05953 mif_attr_map[child_idx] = mif_attr_map[attr_idx]; 05954 05955 EXIT: 05956 05957 TRACE (Func_Exit, "cvrt_attr_ntry", NULL); 05958 05959 return(mif_attr_map[attr_idx].val); 05960 05961 } /* cvrt_attr_ntry */ 05962 05963 05964 05965 05966 /******************************************************************************\ 05967 |* *| 05968 |* Description: *| 05969 |* Interface to the constant folding routines for conversion in data *| 05970 |* statement processing. TYPELESS constants are left typeless so that *| 05971 |* multiple words may be initialized with single constants. *| 05972 |* *| 05973 |* Input parameters: *| 05974 |* incoming constant, its type table index, and target type index *| 05975 |* *| 05976 |* Output parameters: *| 05977 |* operand *| 05978 |* *| 05979 |* Returns: *| 05980 |* NOTHING *| 05981 |* *| 05982 \******************************************************************************/ 05983 static void cvrt_const (char *constptr, 05984 int origtypeix, 05985 int desttypeix, 05986 mopd_t *opd) 05987 { 05988 05989 int basic; 05990 char cbuf[16000]; 05991 05992 TRACE (Func_Entry, "cvrt_const", NULL); 05993 05994 basic = get_basic_type(desttypeix); 05995 05996 if (TYP_TYPE(origtypeix) == Typeless) { 05997 basic = get_basic_type(origtypeix); 05998 } 05999 06000 if (TYP_TYPE(origtypeix) != Typeless) { 06001 06002 switch(TYP_TYPE(desttypeix)) { 06003 case Character : 06004 folder_driver(constptr, /* first operand value */ 06005 origtypeix, /* first operand type index */ 06006 NULL, /* second operand value */ 06007 NULL_IDX, /* second operand type index */ 06008 &cbuf, /* result value */ 06009 &desttypeix, /* result type index */ 06010 msp.scope[local_scope].start.line, 06011 0, /* col number of constant */ 06012 1, /* number of vararg arguments */ 06013 Cvrt_Opr); 06014 constptr = cbuf; 06015 break; 06016 06017 case Integer : 06018 case Logical : 06019 case Real : 06020 case Complex : 06021 if (TYP_LINEAR(origtypeix) != TYP_LINEAR(desttypeix)) { 06022 folder_driver(constptr, /* first operand value */ 06023 origtypeix, /* first operand type index */ 06024 NULL, /* second operand value */ 06025 NULL_IDX, /* second operand type index */ 06026 &cbuf, /* result value */ 06027 &desttypeix, /* result type index */ 06028 msp.scope[local_scope].start.line, 06029 0, /* col number of constant */ 06030 1, /* number of vararg arguments */ 06031 Cvrt_Opr); 06032 constptr = cbuf; 06033 break; 06034 } 06035 } 06036 } 06037 06038 opd->tag = mtag_con; 06039 opd->val = mcon_lookup(&msp, basic, constptr, NONE); 06040 06041 TRACE (Func_Exit, "cvrt_const", NULL); 06042 } /* cvrt_const */ 06043 06044 06045 06046 /******************************************************************************\ 06047 |* *| 06048 |* Description: *| 06049 |* Fold an expression containing constants and DATA implied DO control *| 06050 |* variables. Addressing operations are evaluated into bit offsets. *| 06051 |* *| 06052 |* Input parameters: *| 06053 |* index and field type *| 06054 |* *| 06055 |* Output parameters: *| 06056 |* NONE *| 06057 |* *| 06058 |* Returns: *| 06059 |* integer result *| 06060 |* *| 06061 \******************************************************************************/ 06062 static int fold_exp(int idx, 06063 fld_type field, 06064 int *baseattr, /* base variable */ 06065 int *fldattr, /* base component */ 06066 int *typeix) /* MIF type index */ 06067 { 06068 06069 int res; 06070 int i; 06071 int vv; 06072 int cn_idx; 06073 opnd_type l_opnd; 06074 int lb, str, off; 06075 int next_idx; 06076 int sym2ix; 06077 int dim; 06078 int atypeix, btypeix; 06079 06080 TRACE (Func_Entry, "fold_exp", NULL); 06081 06082 /* BECKER - function is not TARGET sensitive. Need to use arith.a */ 06083 06084 switch (field) { 06085 06086 case CN_Tbl_Idx : 06087 res = CN_INT_TO_C(idx); 06088 if (typeix) { 06089 *typeix = get_basic_type(CN_TYPE_IDX(idx)); 06090 } 06091 break; 06092 06093 case AT_Tbl_Idx : 06094 for (i = 0; i <= do_control_idx; i++) { 06095 if (do_control_var[i] == idx) { 06096 res = implied_do_idx[i]; 06097 if (typeix) { 06098 *typeix = msp.immtype; 06099 } 06100 break; 06101 } 06102 } 06103 if (i > do_control_idx) { 06104 res = 0; 06105 if (baseattr) { 06106 *baseattr = idx; 06107 } 06108 if (fldattr) { 06109 *fldattr = idx; 06110 } 06111 if (typeix) { 06112 if (mif_attr_map[idx].tag == mtag_gsym) { 06113 *typeix = msp.gsym[mif_attr_map[idx].val].type; 06114 } 06115 else { 06116 *typeix = msp.lsym[mif_attr_map[idx].val].type; 06117 } 06118 } 06119 } 06120 break; 06121 06122 case IR_Tbl_Idx : 06123 06124 switch (IR_OPR(idx)) { 06125 06126 case Plus_Opr : 06127 res = fold_exp(IR_IDX_L(idx), IR_FLD_L(idx), 0, 0, 0) + 06128 fold_exp(IR_IDX_R(idx), IR_FLD_R(idx), 0, 0, 0); 06129 break; 06130 06131 case Minus_Opr : 06132 res = fold_exp(IR_IDX_L(idx), IR_FLD_L(idx), 0, 0, 0) - 06133 fold_exp(IR_IDX_R(idx), IR_FLD_R(idx), 0, 0, 0); 06134 break; 06135 06136 case Mult_Opr : 06137 res = fold_exp(IR_IDX_L(idx), IR_FLD_L(idx), 0, 0, 0) * 06138 fold_exp(IR_IDX_R(idx), IR_FLD_R(idx), 0, 0, 0); 06139 break; 06140 06141 case Div_Opr : 06142 res = fold_exp(IR_IDX_L(idx), IR_FLD_L(idx), 0, 0, 0) / 06143 fold_exp(IR_IDX_R(idx), IR_FLD_R(idx), 0, 0, 0); 06144 break; 06145 06146 case Power_Opr : 06147 res = (long)pow((double)fold_exp(IR_IDX_L(idx), 06148 IR_FLD_L(idx), 0, 0, 0), 06149 (double)fold_exp(IR_IDX_R(idx), 06150 IR_FLD_R(idx), 0, 0, 0)); 06151 break; 06152 06153 case Uplus_Opr : 06154 case Paren_Opr : 06155 res = fold_exp(IR_IDX_L(idx), IR_FLD_L(idx), 06156 baseattr, fldattr, typeix); 06157 break; 06158 06159 case Uminus_Opr : 06160 res = -fold_exp(IR_IDX_L(idx), IR_FLD_L(idx), 0, 0, 0); 06161 break; 06162 06163 case Subscript_Opr : 06164 case Section_Subscript_Opr : 06165 case Whole_Subscript_Opr : 06166 06167 /* base variable */ 06168 res = fold_exp(IR_IDX_L(idx), IR_FLD_L(idx), 06169 baseattr, fldattr, &atypeix); 06170 btypeix = msp.type[atypeix].marray.base; 06171 if (typeix) { 06172 *typeix = btypeix; 06173 } 06174 06175 off = 0; 06176 next_idx = IR_IDX_R(idx); 06177 for (dim = 0; dim < msp.type[atypeix].marray.rank; dim++) { 06178 06179 COPY_OPND(l_opnd, IL_OPND(next_idx)); 06180 /* l_opnd will always be a scalar expression here */ 06181 vv = 1; 06182 cn_idx = get_next_array_expr_element(&l_opnd, 06183 &vv); 06184 COPY_OPND(IL_OPND(next_idx), l_opnd); 06185 i = CN_INT_TO_C(cn_idx); 06186 06187 if (msp.type[atypeix].marray.low[dim].tag != mtag_imm) { 06188 lb = mif_con_to_host_long(&msp, 06189 msp.type[atypeix].marray.low[dim].val); 06190 } 06191 else { 06192 lb = msp.type[atypeix].marray.low[dim].val; 06193 } 06194 06195 if (msp.type[atypeix].marray.stride[dim].tag != mtag_imm) { 06196 str = mif_con_to_host_long(&msp, 06197 msp.type[atypeix].marray.stride[dim].val); 06198 } 06199 else { 06200 str = msp.type[atypeix].marray.stride[dim].val; 06201 } 06202 06203 off += (i - lb) * str; 06204 next_idx = IL_NEXT_LIST_IDX(next_idx); 06205 } 06206 06207 /* compute bit offset from element offset, using right units */ 06208 while (VALID(msp.type[btypeix].u.base)) { 06209 btypeix = msp.type[btypeix].u.base; 06210 } 06211 if (msp.type[btypeix].u.class == mtypeclass_fchar) { 06212 off *= msp.type[btypeix].mfchar.prec; 06213 } 06214 else { 06215 off *= TARGET_BITS_PER_WORD; 06216 } 06217 res += off; 06218 06219 break; 06220 06221 case Whole_Substring_Opr : 06222 case Substring_Opr : 06223 res = fold_exp(IR_IDX_L(idx), 06224 IR_FLD_L(idx), 06225 baseattr, 06226 fldattr, 06227 &btypeix); 06228 06229 if (typeix) { 06230 *typeix = btypeix; 06231 } 06232 06233 i = fold_exp(IL_IDX(IR_IDX_R(idx)), 06234 IL_FLD(IR_IDX_R(idx)), 06235 0, 0, 0); 06236 06237 res += (i - 1) * msp.type[btypeix].mfchar.prec; 06238 break; 06239 06240 case Struct_Opr : 06241 res = fold_exp(IR_IDX_L(idx), 06242 IR_FLD_L(idx), 06243 baseattr, 0, &atypeix); 06244 06245 if (fldattr) { 06246 *fldattr = IR_IDX_R(idx); 06247 } 06248 06249 sym2ix = mif_attr_map[IR_IDX_R(idx)].val; 06250 res += msp.sym2[sym2ix].offset.val; 06251 06252 if (typeix) { 06253 *typeix = msp.sym2[sym2ix].type; 06254 } 06255 break; 06256 06257 default : 06258 PRINTMSG(1, 1044, Internal, 0, "fold_exp: unknown operator"); 06259 } 06260 break; 06261 06262 default : 06263 PRINTMSG(1, 1044, Internal, 0, "fold_exp: bad field type"); 06264 } 06265 06266 TRACE (Func_Exit, "fold_exp", NULL); 06267 06268 return(res); 06269 } /* fold_exp */ 06270 06271 06272 06273 /******************************************************************************\ 06274 |* *| 06275 |* Description: *| 06276 |* Process a DATA statement implied DO *| 06277 |* *| 06278 |* Input parameters: *| 06279 |* *| 06280 |* Output parameters: *| 06281 |* NONE *| 06282 |* *| 06283 |* Returns: *| 06284 |* NOTHING *| 06285 |* *| 06286 \******************************************************************************/ 06287 static void cvrt_data_impl_do(int idx, 06288 fld_type field) 06289 { 06290 int l_idx; 06291 opnd_type l_opnd; 06292 int initix; 06293 int bpinitix; 06294 int cn_idx; 06295 int count; 06296 int listidx; 06297 int start, end, step; /* I=start,end,step */ 06298 int dir; 06299 int baseattr; 06300 int fldattr; 06301 int typeix, blanktypeix; 06302 int vv; 06303 long t; 06304 mtype_t type; 06305 long_type the_constant[MAX_WORDS_FOR_NUMERIC]; 06306 06307 TRACE (Func_Entry, "cvrt_data_impl_do", NULL); 06308 06309 switch (field) { 06310 06311 case IL_Tbl_Idx : 06312 while (idx != NULL_IDX) { 06313 cvrt_data_impl_do(IL_IDX(idx), IL_FLD(idx)); 06314 idx = IL_NEXT_LIST_IDX(idx); 06315 } 06316 break; 06317 06318 case IR_Tbl_Idx : 06319 06320 if (IR_OPR(idx) == Implied_Do_Opr) { 06321 06322 do_control_idx++; 06323 06324 /* Extract loop control information */ 06325 listidx = IR_IDX_R(idx); 06326 do_control_var[do_control_idx] = IL_IDX(listidx); 06327 listidx = IL_NEXT_LIST_IDX(listidx); 06328 start = fold_exp(IL_IDX(listidx), IL_FLD(listidx), 0, 0, 0); 06329 listidx = IL_NEXT_LIST_IDX(listidx); 06330 end = fold_exp(IL_IDX(listidx), IL_FLD(listidx), 0, 0, 0); 06331 listidx = IL_NEXT_LIST_IDX(listidx); 06332 step = fold_exp(IL_IDX(listidx), IL_FLD(listidx), 0, 0, 0); 06333 listidx = IL_NEXT_LIST_IDX(listidx); 06334 06335 /* Iterate over the loop body */ 06336 dir = step > 0 ? 1 : -1; 06337 for (implied_do_idx[do_control_idx] = start; 06338 dir * implied_do_idx[do_control_idx] <= dir * end; 06339 implied_do_idx[do_control_idx] += step) { 06340 06341 the_constant[0] = implied_do_idx[do_control_idx]; 06342 06343 if (listidx == NULL_IDX) { 06344 /* intentionally blank */ 06345 } 06346 else { 06347 COPY_OPND(l_opnd, IL_OPND(listidx)); 06348 vv = implied_do_idx[do_control_idx]; 06349 cn_idx = get_next_array_expr_element(&l_opnd, &vv); 06350 COPY_OPND(IL_OPND(listidx), l_opnd); 06351 06352 the_constant[0] = CN_INT_TO_C(cn_idx); 06353 } 06354 06355 # ifdef _TARGET32 06356 if (TYP_LINEAR(ATD_TYPE_IDX(do_control_var[do_control_idx])) 06357 == Integer_8) { 06358 06359 the_constant[1] = the_constant[0]; 06360 the_constant[0] = 0; 06361 } 06362 # endif 06363 06364 SET_LCV_CONST(do_control_var[do_control_idx], 06365 (the_constant[0]), 06366 num_host_wds[TYP_LINEAR(ATD_TYPE_IDX( 06367 do_control_var[do_control_idx]))]); 06368 06369 cvrt_data_impl_do(IR_IDX_L(idx), IR_FLD_L(idx)); 06370 } 06371 06372 do_control_idx--; 06373 06374 } 06375 else { 06376 06377 /* Must be a variable reference; perform a single initialization */ 06378 initix = mifalloc[mtag_init](&msp); 06379 06380 /* Determine base variable, bit offset, and field size of */ 06381 /* this initialization. */ 06382 msp.init[initix].offset = fold_exp(idx, 06383 field, 06384 &baseattr, 06385 &fldattr, 06386 &typeix); 06387 06388 /* Get next constant */ 06389 count = 1; 06390 if (IL_FLD(data_value_idx) == IR_Tbl_Idx) { 06391 cn_idx = IR_IDX_R(IL_IDX(data_value_idx)); 06392 if (IR_FLD_R(IL_IDX(data_value_idx)) == IR_Tbl_Idx) { 06393 count = CN_INT_TO_C(IR_IDX_L(cn_idx)); 06394 cn_idx = IR_IDX_R(cn_idx); 06395 } 06396 } 06397 else if (IL_FLD(data_value_idx) == CN_Tbl_Idx) { 06398 cn_idx = IL_IDX(data_value_idx); 06399 } 06400 06401 /* Convert to type of destination variable. */ 06402 cvrt_const((char *)&CN_CONST(cn_idx), 06403 CN_TYPE_IDX(cn_idx), 06404 ATD_TYPE_IDX(fldattr), 06405 &msp.init[initix].val); 06406 06407 if ((TYP_TYPE(CN_TYPE_IDX(cn_idx)) == Character) && 06408 (TYP_TYPE(ATD_TYPE_IDX(fldattr)) != Integer)) { 06409 if ((IR_OPR(idx) == Substring_Opr) || 06410 (IR_OPR(idx) == Whole_Substring_Opr)) { 06411 l_idx = IR_IDX_R(idx); 06412 l_idx = IL_NEXT_LIST_IDX(l_idx); 06413 l_idx = IL_NEXT_LIST_IDX(l_idx); 06414 msp.init[initix].size = CN_INT_TO_C(IL_IDX(l_idx)) * CHAR_BIT; 06415 } 06416 else { 06417 msp.init[initix].size = 06418 CN_INT_TO_C(TYP_IDX(CN_TYPE_IDX(cn_idx))) * CHAR_BIT; 06419 } 06420 } 06421 else { 06422 if (msp.type[typeix].u.size.tag != mtag_imm) { 06423 t = mif_con_to_host_long(&msp, 06424 msp.type[typeix].u.size.val); 06425 } 06426 else { 06427 t = msp.type[typeix].u.size.val; 06428 } 06429 06430 msp.init[initix].size = t; 06431 } 06432 msp.init[initix].count = count; 06433 msp.init[initix].stride = msp.init[initix].size; 06434 06435 insert_init(initix, 06436 mif_attr_map[baseattr].tag, 06437 mif_attr_map[baseattr].val); 06438 06439 /* Step to the next constant for the next initializer */ 06440 if (IL_FLD(data_value_idx) != IR_Tbl_Idx || 06441 ++data_values_consumed == 06442 /* rep ct */ CN_INT_TO_C(IR_IDX_L(IL_IDX(data_value_idx)))) { 06443 data_value_idx = IL_NEXT_LIST_IDX(data_value_idx); 06444 data_values_consumed = 0; 06445 } 06446 06447 } 06448 break; 06449 } 06450 06451 TRACE (Func_Exit, "cvrt_data_impl_do", NULL); 06452 } /* cvrt_data_impl_do */ 06453 06454 06455 06456 06457 /******************************************************************************\ 06458 |* *| 06459 |* Description: *| 06460 |* Read a module information table from a file and package it as a *| 06461 |* intermediate language subprogram. *| 06462 |* *| 06463 |* Input parameters: *| 06464 |* Output file stdio pointer *| 06465 |* *| 06466 |* Output parameters: *| 06467 |* NONE *| 06468 |* *| 06469 |* Returns: *| 06470 |* NOTHING *| 06471 |* *| 06472 \******************************************************************************/ 06473 static void write_mod_tbl_file_name (FILE *out_fp) 06474 { 06475 06476 int fp_idx; 06477 long end_ftell; 06478 char *mod_info_fn; 06479 int mod_info_len; 06480 char *mod_info_tab; 06481 FILE *modfile; 06482 long start_ftell; 06483 mtype_t type; 06484 06485 06486 TRACE (Func_Entry, "write_mod_tbl_file_name", NULL); 06487 06488 /* NOTE: CRAY is the only implementation that requires the @%% stuff. */ 06489 06490 fp_idx = ATP_MOD_PATH_IDX(SCP_ATTR_IDX(MAIN_SCP_IDX)); 06491 06492 if (!FP_OUTPUT_TO_O(fp_idx)) { 06493 return; /* Do not want permanent module output */ 06494 } 06495 06496 06497 # if defined(_TARGET_OS_UNICOS) 06498 06499 init_subprog_info (NULL_IDX); 06500 06501 /* reate special name to identify module information. */ 06502 06503 msp.name = mnpool(&msp, "@%%"); 06504 06505 /* Create a function returning void type. */ 06506 06507 type = *mtype_null[mtypeclass_func]; 06508 type.mfunc.base = mtype_lookup(&msp, mtype_null[mtypeclass_void]); 06509 06510 /* Create a function which holds the module information */ 06511 06512 msp.deffunc = mifalloc[mtag_func](&msp); 06513 msp.func[msp.deffunc].name = msp.name; 06514 msp.func[msp.deffunc].flags |= mfuncflag_module; 06515 msp.func[msp.deffunc].lang = mlang_F90; 06516 msp.func[msp.deffunc].type = mtype_lookup(&msp, &type); 06517 06518 /* Output module information subprogram and */ 06519 /* free memory of in-core representation. */ 06520 06521 # endif 06522 06523 msp.modfile = mnpool(&msp, FP_NAME_PTR(fp_idx)); 06524 06525 # if defined(_TARGET_OS_UNICOS) 06526 06527 mifwrite (out_fp, &msp, cmd_line_flags.output_format, "/bin/cat"); 06528 miffree (&msp); 06529 06530 # endif 06531 06532 TRACE (Func_Exit, "write_mod_tbl_file_name", NULL); 06533 06534 } /* write_mod_tbl_file_name */ 06535 06536 06537 06538 06539 /******************************************************************************\ 06540 |* *| 06541 |* Description: *| 06542 |* Set up MIF subprogram header , src table, and product information *| 06543 |* *| 06544 |* Input parameters: *| 06545 |* NONE *| 06546 |* *| 06547 |* Output parameters: *| 06548 |* NONE *| 06549 |* *| 06550 |* Returns: *| 06551 |* NOTHING *| 06552 |* *| 06553 \******************************************************************************/ 06554 06555 static void init_subprog_info(int attr_idx) { 06556 06557 /* only initialize environment information once */ 06558 06559 static char targetname [MACHINENAMELEN]; 06560 static struct stat statbuf; 06561 06562 int act_file_line; 06563 int i; 06564 int j; 06565 mpos_t pos; 06566 char *act_file_name; 06567 char *act_path_name; 06568 06569 # if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX) 06570 struct target data; 06571 # else 06572 char *p; 06573 #endif 06574 06575 TRACE (Func_Entry, "init_subprog_info", NULL); 06576 06577 06578 if (src_path == 0) { 06579 06580 /* first time function called, get environment information */ 06581 06582 gethostname(hostname, MACHINENAMELEN); 06583 06584 src_path = get_src_path_name(); 06585 stat (src_path, &statbuf); 06586 06587 # if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX) 06588 target(MC_GET_TARGET, &data); 06589 strcpy (targetname, (char *)&data.mc_pmt); 06590 # else 06591 06592 p = getenv("TARGET"); 06593 06594 if (p) { 06595 strcpy (targetname, p); 06596 } 06597 else { /* If TARGET not set, assume same as host */ 06598 strcpy (targetname, hostname); 06599 } 06600 # endif 06601 } 06602 06603 msp = msubprog_null; 06604 06605 /* Subprogram header information */ 06606 msp.version = MIFVERS; 06607 06608 /* command line info */ 06609 if (cmd_line_flags.dalign) { 06610 msp.flags |= msubprogflag_dalign; 06611 } 06612 06613 /* If this is a module procedure or internal procedure that has come */ 06614 /* in via a USE statement and is being sent across only for inlining */ 06615 /* purposes, mark is as reference only. */ 06616 06617 if (SCP_IS_USED_PROC(curr_scp_idx)) { 06618 msp.flags |= msubprogflag_refonly; 06619 } 06620 06621 /* Initialize product table entry for frontend */ 06622 F90_prod_mif_idx = mifalloc[mtag_prod](&msp); 06623 msp.prod[F90_prod_mif_idx].lang = mlang_F90; 06624 msp.prod[F90_prod_mif_idx].component = mnpool(&msp, "CFT90 frontend"); 06625 msp.prod[F90_prod_mif_idx].config = mnpool(&msp, 06626 # ifdef _STANDALONE_FRONT_END 06627 "standalone" 06628 # else 06629 "composite" 06630 # endif 06631 # ifdef _DEBUG 06632 " debug" 06633 # endif 06634 # ifdef _TARGET32 06635 " 32bit" 06636 # endif 06637 # ifdef CRAY 06638 " Cray" 06639 # endif 06640 # ifdef SPARC 06641 " SPARC" 06642 # endif 06643 ); 06644 msp.prod[F90_prod_mif_idx].version = mnpool(&msp, frontend_version); 06645 06646 06647 /* Initialize source table entry for source file. */ 06648 srcix = mifalloc[mtag_src](&msp); 06649 act_file_name = GL_FILE_NAME_PTR(1); 06650 act_path_name = GL_PATH_NAME_PTR(1); 06651 msp.src[srcix].path = mnpool(&msp, act_path_name); 06652 msp.src[srcix].origname = mnpool(&msp, act_file_name); 06653 msp.src[srcix].host = mnpool(&msp, hostname); 06654 msp.src[srcix].time = statbuf.st_ctime; 06655 msp.src[srcix].product = F90_prod_mif_idx; 06656 msp.src[srcix].lines = GL_SOURCE_LINES(1); 06657 GL_MIF_FILE_ID(1) = srcix; 06658 06659 for (i = 2; i <= global_line_tbl_idx; i++) { 06660 06661 if (GL_INCLUDE_FILE_LINE(i) != 0) { 06662 srcix = mifalloc[mtag_src](&msp); 06663 act_file_name = GL_FILE_NAME_PTR(i); 06664 act_path_name = GL_PATH_NAME_PTR(i); 06665 msp.src[srcix].path = mnpool(&msp, act_path_name); 06666 msp.src[srcix].origname = mnpool(&msp, act_file_name); 06667 msp.src[srcix].host = mnpool(&msp, hostname); 06668 msp.src[srcix].time = statbuf.st_ctime; 06669 msp.src[srcix].product = F90_prod_mif_idx; 06670 msp.src[srcix].lines = GL_SOURCE_LINES(i); 06671 pos = mpos_null; 06672 pos.src = GL_MIF_FILE_ID(i-1); 06673 pos.line = GL_INCLUDE_FILE_LINE(i); 06674 pos.col = GL_INCLUDE_FILE_COL(i); 06675 msp.src[srcix].pos = pos; 06676 GL_MIF_FILE_ID(i) = srcix; 06677 } 06678 else { 06679 j = i-1; 06680 while (GL_CIF_FILE_ID(i) != GL_CIF_FILE_ID(j)) { 06681 j = j - 1; 06682 } 06683 GL_MIF_FILE_ID(i) = GL_MIF_FILE_ID(j); 06684 } 06685 } 06686 06687 06688 /* Initialize the options table. */ 06689 optionix = mifalloc[mtag_option](&msp); 06690 06691 create_option_tbl(); 06692 msp.option->target = mnpool(&msp, targetname); 06693 06694 TRACE (Func_Exit, "init_subprog_info", NULL); 06695 06696 } /* init_subprog_info */ 06697 06698 06699 /******************************************************************************\ 06700 |* *| 06701 |* Description: *| 06702 |* Set up MIF option table. *| 06703 |* *| 06704 |* Input parameters: *| 06705 |* NONE *| 06706 |* *| 06707 |* Output parameters: *| 06708 |* NONE *| 06709 |* *| 06710 |* Returns: *| 06711 |* NOTHING *| 06712 |* *| 06713 \******************************************************************************/ 06714 static void create_option_tbl(void) 06715 06716 { 06717 int disable_idx; 06718 int i; 06719 Uint *mif_disable_msg_list = 0; 06720 int msg_num; 06721 06722 06723 TRACE (Func_Entry, "create_option_tbl", NULL); 06724 06725 /* optimization levels */ 06726 06727 msp.option[optionix].inline_level = opt_flags.inline_lvl; 06728 msp.option[optionix].vector_level = opt_flags.vector_lvl; 06729 msp.option[optionix].scalar_level = opt_flags.scalar_lvl; 06730 msp.option[optionix].task_level = opt_flags.task_lvl; 06731 06732 /* optmization control flags */ 06733 06734 msp.option[optionix].opt_flags = 0; 06735 06736 if (opt_flags.neg_msgs) { 06737 msp.option[optionix].opt_flags |= moptflag_negmsg; 06738 } 06739 06740 if (opt_flags.aggress) { 06741 msp.option[optionix].opt_flags |= moptflag_aggress; 06742 } 06743 06744 if (opt_flags.pattern) { 06745 msp.option[optionix].opt_flags |= moptflag_pattern; 06746 } 06747 06748 if (opt_flags.taskinner) { 06749 msp.option[optionix].opt_flags |= moptflag_taskinner; 06750 } 06751 06752 if (opt_flags.threshold) { 06753 msp.option[optionix].opt_flags |= moptflag_threshold; 06754 } 06755 06756 if (opt_flags.zeroinc) { 06757 msp.option[optionix].opt_flags |= moptflag_zeroinc; 06758 } 06759 06760 if (opt_flags.over_index) { 06761 msp.option[optionix].opt_flags |= moptflag_overindex; 06762 } 06763 06764 if (cmd_line_flags.runtime_conformance) { 06765 msp.option[optionix].opt_flags |= moptflag_conform; 06766 } 06767 06768 if (opt_flags.ieeeconform) { 06769 msp.option[optionix].opt_flags |= moptflag_ieeeconform; 06770 } 06771 06772 /* From PDGCS: */ 06773 /* PDGCS_init(), init_flags, PDGCS_INIT_MEM_HIER_OPT */ 06774 06775 /* Set this bit to TRUE if */ 06776 /* ( ( "-Ounroll2" is enabled ) */ 06777 06778 /* mif uses this flag to set PDGCS_INIT_MEM_HIER_OPT */ 06779 06780 06781 if (opt_flags.unroll_lvl == Unroll_Lvl_2) { 06782 msp.option[optionix].opt_flags |= moptflag_unroll; 06783 } 06784 06785 if (opt_flags.split_lvl > Split_Lvl_0) { 06786 msp.option[optionix].opt_flags |= moptflag_streamsplit; 06787 } 06788 06789 /* Fortran does not have an unroll count. Leave unset for now. */ 06790 /* unsigned int unroll_count : 8; */ 06791 06792 /* maximum number of ERRORs to emit */ 06793 06794 if (on_off_flags.abort_if_any_errors) { 06795 msp.option[optionix].error_limit = 1; 06796 } 06797 else if (on_off_flags.abort_on_100_errors) { 06798 msp.option[optionix].error_limit = 100; 06799 } 06800 else { 06801 msp.option[optionix].error_limit = 0; /* 0 means no limit. */ 06802 } 06803 06804 /* number of disabled messages */ 06805 06806 if (cmd_line_flags.num_msgs_suppressed) { 06807 MEM_ALLOC(mif_disable_msg_list, Uint, cmd_line_flags.num_msgs_suppressed); 06808 06809 for (disable_idx = 0; 06810 disable_idx < cmd_line_flags.num_msgs_suppressed; 06811 disable_idx++) { 06812 06813 for (i = 0; i < MAX_MSG_DISABLE_SIZE; ++i) { 06814 06815 if (msg_suppress_tbl[i] != 0) { 06816 06817 for (msg_num = i * HOST_BITS_PER_WORD; 06818 msg_num < (i + 1) * HOST_BITS_PER_WORD; 06819 ++msg_num) { 06820 06821 if (GET_MSG_SUPPRESS_TBL(msg_num)) { 06822 mif_disable_msg_list[disable_idx] = msg_num; 06823 } 06824 } 06825 } 06826 } 06827 } 06828 } 06829 06830 msp.option[optionix].disabled_msgs = mif_disable_msg_list; 06831 msp.option[optionix].disabled_msgs_ct = cmd_line_flags.num_msgs_suppressed; 06832 06833 /* messages enabled - Fortran does not accept this option */ 06834 /* unsigned int *enabled_msgs; */ 06835 06836 msp.option[optionix].enabled_msgs_ct = 0; 06837 06838 /* message severity control */ 06839 06840 msp.option[optionix].msg_severityflags = mmsg_severityflag_internal | 06841 mmsg_severityflag_limit | 06842 mmsg_severityflag_log_Error | 06843 mmsg_severityflag_log_Summary | 06844 mmsg_severityflag_log_warning; 06845 06846 if (on_off_flags.check_std) { /* Issue ANSI */ 06847 msp.option[optionix].msg_severityflags |= mmsg_severityflag_ansi; 06848 } 06849 06850 if (cmd_line_flags.msg_lvl_suppressed == Error_Lvl) { 06851 msp.option[optionix].msg_severityflags |= mmsg_severityflag_error; 06852 } 06853 else if (cmd_line_flags.msg_lvl_suppressed == Warning_Lvl) { 06854 msp.option[optionix].msg_severityflags |= mmsg_severityflag_warning | 06855 mmsg_severityflag_error; 06856 } 06857 else if (cmd_line_flags.msg_lvl_suppressed == Caution_Lvl) { 06858 msp.option[optionix].msg_severityflags |= mmsg_severityflag_caution | 06859 mmsg_severityflag_warning | 06860 mmsg_severityflag_error; 06861 } 06862 else if (cmd_line_flags.msg_lvl_suppressed == Note_Lvl) { 06863 msp.option[optionix].msg_severityflags |= mmsg_severityflag_note | 06864 mmsg_severityflag_caution | 06865 mmsg_severityflag_warning | 06866 mmsg_severityflag_error; 06867 } 06868 else if (cmd_line_flags.msg_lvl_suppressed == Comment_Lvl) { 06869 msp.option[optionix].msg_severityflags |= mmsg_severityflag_comment | 06870 mmsg_severityflag_note | 06871 mmsg_severityflag_caution | 06872 mmsg_severityflag_warning | 06873 mmsg_severityflag_error; 06874 } 06875 06876 06877 if ((cif_flags & MESSAGE_RECS) || opt_flags.msgs) { 06878 msp.option[optionix].msg_severityflags |= mmsg_severityflag_info | 06879 mmsg_severityflag_vector | 06880 mmsg_severityflag_scalar | 06881 mmsg_severityflag_table | 06882 mmsg_severityflag_inline | 06883 mmsg_severityflag_tasking | 06884 mmsg_severityflag_optimization; 06885 } 06886 06887 /* debugging level */ 06888 06889 if (cmd_line_flags.debug_lvl != 4) { 06890 msp.option[optionix].debug_level = cmd_line_flags.debug_lvl; 06891 } 06892 06893 /* tool control flags */ 06894 06895 msp.option[optionix].tool_flags = 0; 06896 06897 if (on_off_flags.MPP_apprentice) { 06898 msp.option[optionix].tool_flags |= mtoolflag_apprentice; 06899 } 06900 06901 if (on_off_flags.atexpert) { 06902 msp.option[optionix].tool_flags |= mtoolflag_atexpert; 06903 } 06904 06905 if (on_off_flags.flowtrace_option) { 06906 msp.option[optionix].tool_flags |= mtoolflag_flowtrace; 06907 } 06908 06909 if (cmd_line_flags.solaris_profile) { 06910 msp.option[optionix].tool_flags |= mtoolflag_prof; 06911 } 06912 06913 if (cmd_line_flags.runtime_argument || 06914 cmd_line_flags.runtime_arg_entry) { 06915 msp.option[optionix].tool_flags |= mtoolflag_dummyarg_check; 06916 } 06917 06918 /* number of truncation bits */ 06919 06920 msp.option[optionix].trunc_bits = cmd_line_flags.truncate_bits; 06921 06922 /* Don't know what this is. */ 06923 06924 # if 0 06925 /* default IEEE rounding mode */ 06926 06927 unsigned int /* enum mroundmode */ roundmode : 3; 06928 06929 mroundmode_none, /* default value */ 06930 mroundmode_tonearest, /* round to nearest representable value */ 06931 mroundmode_tozero, /* round towards zero */ 06932 mroundmode_upward, /* round up to nearest representable value */ 06933 mroundmode_downward, /* round down to nearest representable value */ 06934 mroundmode_runtime /* IEEE rounding mode set at load or run time */ 06935 # endif 06936 06937 /* arithmetic control flags */ 06938 06939 msp.option[optionix].arith_flags = 0; 06940 06941 if (on_off_flags.enable_double_precision) { 06942 msp.option[optionix].arith_flags = marithflag_enable_double_precision; 06943 } 06944 06945 if (on_off_flags.reciprical_divide) { 06946 msp.option[optionix].arith_flags |= marithflag_ieeedivide; 06947 } 06948 06949 if (!on_off_flags.round_mult_operations) { 06950 06951 /* Turn on truncation vs rounding. Can have one or other. */ 06952 06953 msp.option[optionix].arith_flags |= marithflag_truncate_mode; 06954 } 06955 06956 if (opt_flags.fastint) { 06957 msp.option[optionix].arith_flags |= marithflag_fastmd; 06958 } 06959 06960 /* C only - Fortran does not have target commandline option. */ 06961 /* signed int target : 32; name pool index */ 06962 06963 msp.option[optionix].target_flags = 0; 06964 06965 if (cmd_line_flags.dalign) { 06966 msp.option[optionix].target_flags |= mtargetflag_dalign; 06967 } 06968 06969 /* The -et option causes automatics to be allocated on stack */ 06970 /* rather than on the heap. */ 06971 06972 if (on_off_flags.alloc_autos_on_stack) { 06973 msp.option[optionix].target_flags |= mtargetflag_limit_heap; 06974 } 06975 06976 if (on_off_flags.indef_init) { 06977 msp.option[optionix].target_flags |= mtargetflag_indef; 06978 } 06979 06980 msp.option[optionix].target_flags |= mtargetflag_anytype_aliasing; 06981 06982 if (on_off_flags.upper_case_names) { 06983 msp.option[optionix].target_flags |= mtargetflag_sparc_upper_case; 06984 } 06985 06986 if (cmd_line_flags.small_pic_model) { 06987 msp.option[optionix].target_flags |= mtargetflag_little_pic_model; 06988 } 06989 06990 if (cmd_line_flags.large_pic_model) { 06991 msp.option[optionix].target_flags |= mtargetflag_big_pic_model; 06992 } 06993 06994 return; 06995 06996 TRACE (Func_Exit, "create_option_tbl", NULL); 06997 06998 } /* create_option_tbl */ 06999 07000 07001 07002 /******************************************************************************\ 07003 |* *| 07004 |* Description: *| 07005 |* Close the MIF file after all processing. *| 07006 |* *| 07007 |* Input parameters: *| 07008 |* NONE *| 07009 |* *| 07010 |* Output parameters: *| 07011 |* NONE *| 07012 |* *| 07013 |* Returns: *| 07014 |* NOTHING *| 07015 |* *| 07016 \******************************************************************************/ 07017 void terminate_mif(void) 07018 07019 { 07020 char msgbuf[512]; 07021 07022 07023 TRACE (Func_Entry, "terminate_mif", NULL); 07024 07025 if (MIF_fp) { 07026 07027 if (mif_close_output(MIF_fp, MIF_file, msgbuf) == MIF_FALSE) { 07028 PRINTMSG(1, 1042, Error, 0, MIF_file); 07029 } 07030 } 07031 07032 return; 07033 07034 TRACE (Func_Exit, "terminate_mif", NULL); 07035 07036 } /* terminate_mif */ 07037 07038 # endif
1.7.6.1 
