Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
00001 /* 00002 00003 Copyright (C) 2000, 2001 Silicon Graphics, Inc. All Rights Reserved. 00004 00005 This program is free software; you can redistribute it and/or modify it 00006 under the terms of version 2 of the GNU General Public License as 00007 published by the Free Software Foundation. 00008 00009 This program is distributed in the hope that it would be useful, but 00010 WITHOUT ANY WARRANTY; without even the implied warranty of 00011 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00012 00013 Further, this software is distributed without any warranty that it is 00014 free of the rightful claim of any third person regarding infringement 00015 or the like. Any license provided herein, whether implied or 00016 otherwise, applies only to this software file. Patent licenses, if 00017 any, provided herein do not apply to combinations of this program with 00018 other software, or any other product whatsoever. 00019 00020 You should have received a copy of the GNU General Public License along 00021 with this program; if not, write the Free Software Foundation, Inc., 59 00022 Temple Place - Suite 330, Boston MA 02111-1307, USA. 00023 00024 Contact information: Silicon Graphics, Inc., 1600 Amphitheatre Pky, 00025 Mountain View, CA 94043, or: 00026 00027 http://www.sgi.com 00028 00029 For further information regarding this notice, see: 00030 00031 http://oss.sgi.com/projects/GenInfo/NoticeExplan 00032 00033 */ 00034 00035 00036 /* ==================================================================== 00037 * ==================================================================== 00038 * 00039 * 00040 * Revision history: 00041 * 07-Oct-95 - Original Version 00042 * 00043 * Description: 00044 * 00045 * Defines an interface for a DSO version of whirl2f, with facilities 00046 * for translating a PU at a time or arbitrary subexpressions. 00047 * 00048 * Note that before any of these routines can be called, general 00049 * WHIRL accessor routine initiation must have occurred. 00050 * Furthermore, there is no longer any concept of a .B input file 00051 * (although we assume there may be a .B input file-name), only a 00052 * WN* input tree and SYMTABs. 00053 * 00054 * ==================================================================== 00055 * ==================================================================== 00056 */ 00057 #ifdef _KEEP_RCS_ID 00058 /*REFERENCED*/ 00059 #endif 00060 00061 #include <iostream> 00062 00063 #include <sys/elf_whirl.h> /* for WHIRL_REVISION */ 00064 #include <time.h> 00065 #include <errno.h> /* For sys_errlist */ 00066 #include "whirl2f_common.h" /* For defs.h, config.h, erglob.h, etc. */ 00067 #include "config_opt.h" /* for common config options */ 00068 #include "config_flist.h" /* For FLIST command line parameters */ 00069 #include "config_list.h" /* For List_Cite */ 00070 #include "w2cf_parentize.h" /* For W2CF_Parent_Map and W2FC_Parentize */ 00071 #include "file_util.h" /* For Last_Pathname_Component */ 00072 #include "flags.h" /* for OPTION_GROUP */ 00073 #include "timing.h" /* Start/Stop Timer */ 00074 #include "wn_lower.h" /* WN_lower() */ 00075 #include "wn_tree_util.h" 00076 00077 #include "const.h" /* For FOR_ALL_CONSTANTS */ 00078 #include "PUinfo.h" 00079 #include "st2f.h" 00080 #include "wn2f.h" 00081 #include "wn2f_stmt.h" 00082 #include "wn2f_pragma.h" 00083 #include "unparse_target_ftn.h" 00084 00085 #define DEB_Whirl2f_IR_TY_W2F_Outfile_Translate_Pu 0 00086 00087 /* Avoid errors due to uses of "int" in stdio.h macros. 00088 */ 00089 #undef int 00090 00091 00092 /* ==================================================================== 00093 * 00094 * Local data and macros. 00095 * 00096 * ==================================================================== 00097 */ 00098 00099 /* Default extensions for input/outfile files: */ 00100 static char *W2F_File_Extension[W2F_NUM_FILES] = 00101 { 00102 ".f", /* Fortran input file */ 00103 ".w2f.f", /* Fortran output file */ 00104 ".w2f.loc" /* .loc output file */ 00105 }; 00106 00107 /* CITE extensions for input/outfile files: */ 00108 static char *W2F_Cite_Extension[W2F_NUM_FILES] = 00109 { 00110 ".c", /* original input file */ 00111 "-after-lno.f", /* transformed source */ 00112 ".loc" /* .loc output file */ 00113 }; 00114 00115 /* PROMPF extensions for input/outfile files: */ 00116 static char *W2F_Prompf_Extension[W2F_NUM_FILES] = 00117 { 00118 ".c", /* original input file */ 00119 ".m", /* transformed source */ 00120 ".anl_srcpos" /* srcpos mapping (temporary) output file */ 00121 }; 00122 00123 /* Get the right extension: */ 00124 #define W2F_Extension(i) \ 00125 (W2F_Prompf_Emission? W2F_Prompf_Extension[i] : \ 00126 (List_Cite ? W2F_Cite_Extension[i] : W2F_File_Extension[i])) 00127 00128 00129 /* statements that can be skipped in w2f translation 00130 */ 00131 #define W2F_MAX_SKIP_ITEMS 128 00132 static W2CF_SKIP_ITEM Skip[W2F_MAX_SKIP_ITEMS+1]; 00133 static INT Next_Skip_Item = 0; 00134 00135 00136 /* W2F status information */ 00137 static BOOL W2F_Initialized = FALSE; 00138 static BOOL W2F_Outfile_Initialized = FALSE; 00139 static FORMAT_KIND W2F_Format_Kind = F77_ANSI_FORMAT; 00140 static WN2F_CONTEXT Global_Context = INIT_WN2F_CONTEXT; 00141 static char *W2F_Progname = ""; 00142 static const char *W2F_File_Name[W2F_NUM_FILES] = {NULL, NULL, NULL}; 00143 static BOOL File_Is_Created[W2F_NUM_FILES] = {FALSE, FALSE, FALSE}; 00144 static MEM_POOL W2F_Parent_Pool; 00145 00146 /* External data set through -FLIST command-line options */ 00147 FILE *W2F_File[W2F_NUM_FILES] = {NULL, NULL, NULL}; 00148 BOOL W2F_Enabled = TRUE; /* Invoke W2F */ 00149 BOOL W2F_Verbose = TRUE; /* Show translation information */ 00150 BOOL W2F_Old_F77 = FALSE; /* Use macros for new intrinsics */ 00151 BOOL W2F_Ansi_Format = TRUE; 00152 BOOL W2F_No_Pragmas = FALSE; /* By default, emit pragmas */ 00153 BOOL W2F_Emit_Prefetch = FALSE; /* Emit comments for prefetches */ 00154 BOOL W2F_Emit_All_Regions = FALSE;/* Emit cmplr-generated regions */ 00155 BOOL W2F_Emit_Linedirs = FALSE; /* Emit preproc line-directives */ 00156 // BOOL W2F_Emit_Nested_PUs = FALSE; /* Emit code for nested PUs */ 00157 BOOL W2F_Emit_Nested_PUs = TRUE; 00158 BOOL W2F_Emit_Frequency = FALSE; /* Emit feedback frequency info */ 00159 BOOL W2F_Emit_Cgtag = FALSE; /* Emit codegen tags for loop */ 00160 BOOL W2F_Emit_Pcf = FALSE; /* Force Pcf pragmas wherever possible */ 00161 BOOL W2F_Emit_Omp = FALSE; /* Force OMP pragmas wherever possible */ 00162 INT32 W2F_Line_Length = 0; /* 'zero' means: use the default */ 00163 00164 BOOL W2F_OpenAD; /* Special OpenAD mode set by -openad */ 00165 char W2F_activeType[W2F_ACTIVE_TYPE_LEN]; /* for -openadType <name> */ 00166 00167 /* External data set through the API or otherwise */ 00168 BOOL W2F_Only_Mark_Loads = FALSE; /* Only mark, do not translate loads */ 00169 BOOL WN2F_F90_pu = FALSE; /* Global variable indicating F90 or F77 */ 00170 BOOL W2F_Purple_Emission = FALSE; /* Emitting purple extracted sources */ 00171 BOOL W2F_Prompf_Emission = FALSE; /* Emitting prompf transformed sources */ 00172 WN_MAP *W2F_Construct_Map = NULL; /* Construct id mapping for prompf */ 00173 WN_MAP W2F_Frequency_Map = WN_MAP_UNDEFINED; /* Frequency mapping */ 00174 Unparse_Target *W2X_Unparse_Target = NULL; 00175 00176 TyIdxToStIdxMap tyidx_modidx; 00177 00178 /* ==================================================================== 00179 * 00180 * Process_Command_Line 00181 * 00182 * Process the command line arguments specific to W2F (a.k.a 00183 * phase-specific args). 00184 * 00185 * ==================================================================== 00186 */ 00187 00188 static void 00189 Process_Command_Line (INT argc, char **argv) 00190 { 00191 /* For now we only have the -openad flag. */ 00192 INT16 i; 00193 char *cp; 00194 00195 // we set the default here: 00196 strncpy(W2F_activeType,"oadactive",W2F_ACTIVE_TYPE_LEN); 00197 00198 /* Check the command line flags: */ 00199 for ( i=0; i<argc; i++ ) { 00200 if ( argv[i] != NULL && *(argv[i]) == '-' ) { 00201 cp = argv[i]+1; /* Pointer to next flag character */ 00202 00203 switch ( *cp++ ) { 00204 00205 case 'o': 00206 if ( strcmp( cp, "penad") == 0 ) { 00207 W2F_OpenAD = TRUE; 00208 Show_OPT_Warnings= FALSE; 00209 } 00210 else if ( strcmp( cp, "penadType") == 0 ) { 00211 if (i==argc) { 00212 fprintf(stderr, 00213 "error: the openadType option requires an argument"); 00214 exit(-1); 00215 } 00216 i++; 00217 if (strlen(argv[i])>W2F_ACTIVE_TYPE_LEN) { 00218 fprintf(stderr, 00219 "error: the openadType argument is too long"); 00220 exit(-1); 00221 } 00222 strncpy(W2F_activeType,argv[i],W2F_ACTIVE_TYPE_LEN); 00223 Show_OPT_Warnings= FALSE; 00224 } 00225 break; 00226 } 00227 } 00228 } 00229 } 00230 00231 00232 /* ==================================================================== 00233 * 00234 * Process_Filename_Options() 00235 * 00236 * Once the command line is parsed, check for option interaction. 00237 * 00238 * Open_Read_File() 00239 * Opens the file with the given name and path for reading. 00240 * 00241 * Open_Append_File() 00242 * 00243 * Opens the file with the given name for appending more to its 00244 * end if it already exists, or to create it if it does not 00245 * already exist. 00246 * 00247 * Open_Create_File() 00248 * 00249 * Same as Open_Append_File(), but a new file is always created, 00250 * possibly overwriting an existing file. 00251 * 00252 * Close_File() 00253 * 00254 * Closes the given file if different from NULL and not stdout or 00255 * stderr. 00256 * 00257 * Open_W2f_Output_File() 00258 * 00259 * Assuming that Process_Filename_Options() has been called, open 00260 * the given kind of output file. No effect if the file is already 00261 * open, and the output will be appended to the output file if the 00262 * file has already been created by this process. 00263 * 00264 * Close_W2f_Output_File() 00265 * 00266 * If the file-pointer is non-NULL, we assume the file is open and 00267 * close it. Otherwise, this operation has no effect. 00268 * 00269 * ==================================================================== 00270 */ 00271 00272 static void 00273 Process_Filename_Options(const char *src_filename, const char *irb_filename) 00274 { 00275 /* The name of the original source can be used to derive the 00276 * names of the output .c and .h files when these are not 00277 * explicitly provided. If no original source file-name 00278 * (-W2F:src_file) has been specified, then we assume the name 00279 * given by src_file_name, irb_file_name, or "anonymous.c". 00280 * The -W2F:ftn_file name is derived from the resultant 00281 * -W2F:src_file, unless it is explicitly provided. 00282 * 00283 * Postcondition: 00284 * 00285 * (W2F_File_Name[W2F_ORIG_FILE] != NULL) && 00286 * (W2F_File_Name[W2F_FTN_FILE] != NULL) 00287 */ 00288 #define MAX_FNAME_LENGTH 256-7 /* allow for suffix ".w2f.f\0" */ 00289 static char filename[MAX_FNAME_LENGTH+7]; 00290 char *fname; 00291 00292 /* If we do not have an original source file name, then invent one */ 00293 if (W2F_File_Name[W2F_ORIG_FILE] == NULL) 00294 { 00295 if (src_filename != NULL && src_filename[0] != '\0') 00296 W2F_File_Name[W2F_ORIG_FILE] = src_filename; 00297 else if (irb_filename != NULL && irb_filename[0] != '\0') 00298 W2F_File_Name[W2F_ORIG_FILE] = irb_filename; 00299 else 00300 W2F_File_Name[W2F_ORIG_FILE] = "anonymous.f"; 00301 } 00302 00303 /* Copy the original file-name to a static buffer */ 00304 if (strlen(W2F_File_Name[W2F_ORIG_FILE]) > MAX_FNAME_LENGTH) 00305 { 00306 W2F_File_Name[W2F_ORIG_FILE] = 00307 strncpy(filename, W2F_File_Name[W2F_ORIG_FILE], MAX_FNAME_LENGTH); 00308 filename[MAX_FNAME_LENGTH] = '\0'; 00309 fprintf(stderr, 00310 "WARNING: src_file name truncated to (max=%d chars): \"%s\"\n", 00311 MAX_FNAME_LENGTH, W2F_File_Name[W2F_ORIG_FILE]); 00312 } 00313 else 00314 W2F_File_Name[W2F_ORIG_FILE] = 00315 strcpy(filename, W2F_File_Name[W2F_ORIG_FILE]); 00316 00317 /* We want the output files to be created in the current directory, 00318 * so strip off any directory path, and substitute the suffix 00319 * appropriately. 00320 */ 00321 fname = Last_Pathname_Component(filename); 00322 if (W2F_File_Name[W2F_FTN_FILE] == NULL) 00323 { 00324 W2F_File_Name[W2F_FTN_FILE] = 00325 New_Extension(fname, W2F_Extension(W2F_FTN_FILE)); 00326 } 00327 if (W2F_File_Name[W2F_LOC_FILE] == NULL) 00328 { 00329 if (List_Cite || W2F_Prompf_Emission) 00330 { 00331 W2F_File_Name[W2F_LOC_FILE] = 00332 New_Extension(fname, W2F_Extension(W2F_LOC_FILE)); 00333 } 00334 } 00335 } /* Process_Filename_Options */ 00336 00337 00338 static FILE * 00339 Open_Read_File(const char *filename) 00340 { 00341 FILE *f = NULL; 00342 00343 /* Open the input file */ 00344 if (filename == NULL || 00345 (f = fopen(filename, "r")) == NULL) 00346 { 00347 ErrMsg(EC_IR_Open, filename, errno); 00348 } 00349 return f; 00350 } /* Open_Read_File */ 00351 00352 00353 static FILE * 00354 Open_Append_File(const char *filename) 00355 { 00356 FILE *f = NULL; 00357 00358 /* Open the input file */ 00359 if (filename == NULL || 00360 (f = fopen(filename, "a")) == NULL) 00361 { 00362 ErrMsg(EC_IR_Open, filename, errno); 00363 } 00364 return f; 00365 } /* Open_Append_File */ 00366 00367 00368 static FILE * 00369 Open_Create_File(const char *filename) 00370 { 00371 FILE *f = NULL; 00372 00373 /* Open the input file */ 00374 if (filename == NULL || 00375 (f = fopen(filename, "w")) == NULL) 00376 { 00377 ErrMsg(EC_IR_Open, filename, errno); 00378 } 00379 return f; 00380 } /* Open_Create_File */ 00381 00382 00383 static void 00384 Close_File(const char *filename, FILE *afile) 00385 { 00386 if (afile != NULL && 00387 !Same_File(afile, stdout) && 00388 !Same_File(afile, stderr) && 00389 fclose(afile) != 0) 00390 { 00391 Set_Error_Line(ERROR_LINE_UNKNOWN); /* No line number for error */ 00392 ErrMsg(EC_Src_Close, filename, errno); 00393 } 00394 } /* Close_File */ 00395 00396 00397 static void 00398 Open_W2f_Output_File(W2F_FILE_KIND kind) 00399 { 00400 if (W2F_File[kind] == NULL) 00401 { 00402 if (File_Is_Created[kind]) 00403 { 00404 W2F_File[kind] = Open_Append_File(W2F_File_Name[kind]); 00405 } 00406 else 00407 { 00408 W2F_File[kind] = Open_Create_File(W2F_File_Name[kind]); 00409 File_Is_Created[kind] = TRUE; 00410 } 00411 } /* if (!files_are_open) */ 00412 } /* Open_W2f_Output_File */ 00413 00414 00415 static void 00416 Close_W2f_Output_File(W2F_FILE_KIND kind) 00417 { 00418 Close_File(W2F_File_Name[kind], W2F_File[kind]); 00419 W2F_File[kind] = NULL; 00420 } /* Close_W2f_Output_File */ 00421 00422 00423 /* ==================================================================== 00424 * Begin_New_Location_File: should be called when we start processing 00425 * a new file for which we want locations information. 00426 * 00427 * End_Locations_File: should be called when we end processing of 00428 * a new file for which we want locations information. 00429 * 00430 * Continue_Locations_File: should be called for each PU translation 00431 * for which we want locations information. After the PU 00432 * translation we should call Close_W2f_Output_File(W2F_LOC_FILE). 00433 * 00434 * ==================================================================== 00435 */ 00436 00437 static void 00438 Begin_New_Locations_File(void) 00439 { 00440 /* This should only be called every time a new output file 00441 * is to be generated by whirl2f. Note that we open and 00442 * close the file here, to make sure we only generate entries 00443 * in the location file when W2F_Outfile_Translate_Pu() is called! 00444 */ 00445 if (W2F_File_Name[W2F_LOC_FILE] != NULL) 00446 { 00447 /* Need to do this before writing to a file for which a 00448 * SRCPOS mapping should be maintained. 00449 */ 00450 if (W2F_Prompf_Emission) 00451 { 00452 Open_W2f_Output_File(W2F_LOC_FILE); 00453 Write_String(W2F_File[W2F_LOC_FILE], NULL/* No srcpos map */, 00454 "SRCPOS_MAP_BEGIN\n"); 00455 } 00456 else 00457 { 00458 Open_W2f_Output_File(W2F_LOC_FILE); 00459 Write_String(W2F_File[W2F_LOC_FILE], NULL/* No srcpos map */, 00460 "(SRCPOS-MAP\n"); 00461 } 00462 } 00463 } /* Begin_New_Locations_File */ 00464 00465 00466 static void 00467 End_Locations_File(void) 00468 { 00469 /* This should only be called every time we are done with *all* 00470 * location information for a file. 00471 */ 00472 if (W2F_File_Name[W2F_LOC_FILE] != NULL) 00473 { 00474 /* Need to do this before writing to a file for which a 00475 * SRCPOS mapping should be maintained. 00476 */ 00477 if (W2F_Prompf_Emission) 00478 { 00479 Open_W2f_Output_File(W2F_LOC_FILE); 00480 Write_String(W2F_File[W2F_LOC_FILE], 00481 NULL/* No srcpos map */, 00482 "SRCPOS_MAP_END\n"); 00483 } 00484 else 00485 { 00486 Open_W2f_Output_File(W2F_LOC_FILE); 00487 Write_String(W2F_File[W2F_LOC_FILE], NULL/* No srcpos map */, ")\n"); 00488 } 00489 Terminate_Token_Buffer(W2F_File[W2F_LOC_FILE]); 00490 Close_W2f_Output_File(W2F_LOC_FILE); 00491 } 00492 } /* End_Locations_File */ 00493 00494 00495 static void 00496 Continue_Locations_File(void) 00497 { 00498 /* Need to do this for every PU, i.e. every time 00499 * W2F_Outfile_Translate_Pu() is called. 00500 */ 00501 if (W2F_File_Name[W2F_LOC_FILE] != NULL) 00502 { 00503 Open_W2f_Output_File(W2F_LOC_FILE); 00504 } 00505 } /* Continue_Locations_File */ 00506 00507 00508 static void 00509 Move_Locations_To_Anl_File(const char *loc_fname) 00510 { 00511 #define MAX_ANL_FNAME_LENGTH 256-5 /* allow for suffix ".anl\0" */ 00512 char cbuf[MAX_ANL_FNAME_LENGTH+1]; 00513 INT i, next_ch; 00514 FILE *anl_file; 00515 FILE *loc_file; 00516 char *anl_fname; 00517 static char fname[MAX_ANL_FNAME_LENGTH+5]; 00518 00519 strncpy(fname, loc_fname, MAX_ANL_FNAME_LENGTH); 00520 anl_fname = Last_Pathname_Component(fname); 00521 anl_fname = New_Extension(anl_fname, ".anl"); 00522 anl_file = Open_Append_File(anl_fname); 00523 loc_file = Open_Read_File(loc_fname); 00524 00525 next_ch = getc(loc_file); 00526 while (next_ch != EOF) 00527 { 00528 for (i = 0; (next_ch != EOF && i < MAX_ANL_FNAME_LENGTH); i++) 00529 { 00530 cbuf[i] = next_ch; 00531 next_ch = getc(loc_file); 00532 } 00533 if (i > 0) 00534 { 00535 cbuf[i] = '\0'; 00536 fputs(cbuf, anl_file); 00537 } 00538 } 00539 Close_File(anl_fname, anl_file); 00540 Close_File(loc_fname, loc_file); 00541 remove(loc_fname); 00542 } /* Move_Locations_To_Anl_File */ 00543 00544 00545 /* ==================================================================== 00546 * Undo side-effects to the incoming WHIRL 00547 * --------------------------------------- 00548 * 00549 * W2F_Undo_Whirl_Side_Effects: This subroutine must be called after 00550 * every translation phase which may possibly create side-effects 00551 * in the incoming WHIRL tree. The translation should thus become 00552 * side-effect free as far as concerns the incoming WHIRL tree. 00553 * 00554 * ==================================================================== 00555 */ 00556 00557 static void 00558 W2F_Undo_Whirl_Side_Effects(void) 00559 { 00560 Stab_Free_Tmpvars(); 00561 Stab_Free_Namebufs(); 00562 } 00563 00564 00565 /* ==================================================================== 00566 * Setting up the global symbol table 00567 * ---------------------------------- 00568 * 00569 * W2F_Enter_Global_Symtab: Enter the global symbols into the w2f 00570 * symbol table. The global symbol-table should be the top-of the 00571 * stack at this point. 00572 * 00573 * ==================================================================== 00574 */ 00575 00576 // function object to enter FLD names in w2f symbol table. 00577 // See call in W2F_Enter_Global_Symbols 00578 00579 struct enter_fld 00580 { 00581 void operator() (UINT32 ty_idx, const TY* typ) const 00582 { 00583 00584 const TY & ty = (*typ); 00585 00586 if (TY_kind(ty) == KIND_STRUCT) 00587 { 00588 (void)W2CF_Symtab_Nameof_Ty(ty_idx); 00589 00590 FLD_HANDLE fld = TY_flist(ty); 00591 FLD_ITER fld_iter = Make_fld_iter(fld); 00592 do 00593 { 00594 FLD_HANDLE fld_rt (fld_iter); 00595 00596 if (TY_Is_Pointer(FLD_type(fld_rt))) 00597 (void)W2CF_Symtab_Nameof_Fld_Pointee(fld); 00598 (void)W2CF_Symtab_Nameof_Fld(fld); 00599 00600 } while (!FLD_last_field (fld_iter++)); 00601 } 00602 } 00603 } ; 00604 00605 // function object to enter fn & varbl names in w2f symbol table. 00606 // See call in W2F_Enter_Global_Symbols. 00607 00608 struct enter_st 00609 { 00610 void operator() (UINT32 idx, const ST * st) const 00611 { 00612 if ((ST_sym_class(st) == CLASS_VAR && !ST_is_not_used(st)) || 00613 ST_sym_class(st) == CLASS_FUNC) 00614 { 00615 TY_IDX ty ; 00616 00617 (void)W2CF_Symtab_Nameof_St(st); 00618 00619 if (ST_sym_class(st) == CLASS_VAR) 00620 ty = ST_type(st); 00621 else 00622 ty = ST_pu_type(st); 00623 00624 if (TY_Is_Pointer(ty)) 00625 (void)W2CF_Symtab_Nameof_St_Pointee(st); 00626 } 00627 } 00628 }; 00629 00630 struct build_type_mod_map 00631 { 00632 void operator() (UINT32, ST* st)const { 00633 if ((ST_class(st)==CLASS_TYPE) && 00634 (ST_is_in_module(ST_base(st)))) 00635 { 00636 tyidx_modidx.insert(std::make_pair(ST_type(st),ST_base_idx(st))); 00637 Set_BE_ST_w2fc_referenced(ST_base_idx(st)); 00638 } 00639 } 00640 00641 }; 00642 00643 static void 00644 W2F_Enter_Global_Symbols(void) 00645 { 00646 00647 /* Enter_Sym_Info for every struct or class type in the current 00648 * symbol table, with associated fields. Do this prior to any 00649 * variable declarations, just to ensure that field names and 00650 * common block names retain their names to the extent this is 00651 * possible. 00652 */ 00653 00654 For_all(Ty_Table,enter_fld()); 00655 00656 00657 /* Enter_Sym_Info for every variable and function in the current 00658 * (global) symbol table. Note that we always invent names for the 00659 * pointees of Fortran pointers, since the front-end invariably 00660 * does not generate ST entries for these. 00661 */ 00662 00663 For_all(St_Table,GLOBAL_SYMTAB,enter_st()); 00664 00665 #if 0 00666 // FIX constants ?? 00667 FOR_ALL_CONSTANTS(st, const_idx) 00668 { 00669 if (ST_symclass(st) != CLASS_SYM_CONST) 00670 (void)W2CF_Symtab_Nameof_St(st); 00671 } 00672 #endif 00673 00674 For_all(St_Table,GLOBAL_SYMTAB,build_type_mod_map()); 00675 00676 00677 } /* W2F_Enter_Global_Symbols */ 00678 00679 /* ================================================================= 00680 * Routines for checking correct calling order of excported routines 00681 * ================================================================= 00682 */ 00683 00684 static BOOL 00685 Check_Outfile_Initialized(const char *caller_name) 00686 { 00687 if (!W2F_Outfile_Initialized) 00688 fprintf(stderr, 00689 "NOTE: Ignored call to %s(); call W2F_Outfile_Init() first!\n", 00690 caller_name); 00691 return W2F_Outfile_Initialized; 00692 } /* Check_Outfile_Initialized */ 00693 00694 static BOOL 00695 Check_Initialized(const char *caller_name) 00696 { 00697 if (!W2F_Initialized) 00698 fprintf(stderr, 00699 "NOTE: Ignored call to %s(); call W2F_Init() first!\n", 00700 caller_name); 00701 return W2F_Initialized; 00702 } /* Check_Initialized */ 00703 00704 static BOOL 00705 Check_PU_Pushed(const char *caller_name) 00706 { 00707 if (PUinfo_current_func == NULL) 00708 fprintf(stderr, 00709 "NOTE: Ignored call to %s(); call W2F_Push_PU() first!\n", 00710 caller_name); 00711 return (PUinfo_current_func != NULL); 00712 } /* Check_PU_Pushed */ 00713 00714 00715 /* ================================================================= 00716 * EXPORTED LOW-LEVEL W2F INTERFACE 00717 * -------------------------------- 00718 * 00719 * See comments in w2f_driver.h 00720 * 00721 * ================================================================= 00722 */ 00723 00724 BOOL 00725 W2F_Should_Emit_Nested_PUs(void) 00726 { 00727 return W2F_Emit_Nested_PUs; 00728 } /* W2F_Should_Emit_Nested_PUs */ 00729 00730 00731 void 00732 W2F_Process_Command_Line (INT phase_argc, char *phase_argv[], 00733 INT argc, char *argv[]) 00734 { 00735 /* Get the program name 00736 */ 00737 if (argv[0] != NULL) 00738 W2F_Progname = argv[0]; 00739 00740 /* The processing of the FLIST group was moved out to the back-end. 00741 * Instead of directly using the Current_FLIST, we initiate 00742 * whirl2f specific variables to hold the values. 00743 */ 00744 W2F_File_Name[W2F_ORIG_FILE] = FLIST_orig_filename; 00745 W2F_File_Name[W2F_FTN_FILE] = FLIST_ftn_filename; 00746 W2F_File_Name[W2F_LOC_FILE] = FLIST_loc_filename; 00747 W2F_Enabled = FLIST_enabled; 00748 W2F_Verbose = FLIST_verbose; 00749 W2F_Old_F77 = FLIST_old_f77; 00750 W2F_Ansi_Format = FLIST_ansi_format; 00751 W2F_No_Pragmas = FLIST_no_pragmas; 00752 W2F_Emit_Prefetch = FLIST_emit_prefetch; 00753 W2F_Emit_Linedirs = FLIST_emit_linedirs; 00754 W2F_Emit_All_Regions = FLIST_emit_all_regions; 00755 W2F_Emit_Nested_PUs = TRUE; 00756 W2F_Emit_Frequency = FLIST_emit_frequency; 00757 W2F_Emit_Cgtag = FLIST_emit_cgtag; 00758 W2F_Emit_Pcf = FLIST_emit_pcf; 00759 W2F_Emit_Omp = FLIST_emit_omp; 00760 W2F_Line_Length = FLIST_line_length; 00761 00762 Process_Command_Line(phase_argc, phase_argv); 00763 Process_Filename_Options(Src_File_Name, Irb_File_Name); 00764 00765 if (W2F_Ansi_Format) 00766 W2F_Format_Kind = F77_ANSI_FORMAT; 00767 else 00768 W2F_Format_Kind = F77_ANSI_FORMAT; 00769 00770 } /* W2F_Process_Command_Line */ 00771 00772 00773 void 00774 W2F_Init(void) 00775 { 00776 const char * const caller_err_phase = Get_Error_Phase (); 00777 00778 /* Initialize the various whirl2c subcomponents, unless they 00779 * are already initialized. 00780 */ 00781 if (W2F_Initialized) 00782 return; /* Already initialized */ 00783 00784 Diag_Init(); 00785 if (W2F_Progname != NULL) 00786 Diag_Set_Phase(W2F_Progname); 00787 else 00788 Diag_Set_Phase("FLIST"); 00789 Diag_Set_Max_Diags(100); /* Maximum 100 warnings by default */ 00790 00791 /* Create a pool to hold the parent map for every PU, one at a time. 00792 */ 00793 MEM_POOL_Initialize(&W2F_Parent_Pool, "W2f_Parent_Pool", FALSE); 00794 MEM_POOL_Push(&W2F_Parent_Pool); 00795 00796 00797 /* Always do this first!*/ 00798 00799 Initialize_Token_Buffer(W2F_Format_Kind, W2F_Prompf_Emission); 00800 if (W2F_Line_Length > 0) 00801 Set_Maximum_Linelength(W2F_Line_Length); 00802 00803 W2X_Unparse_Target = new Unparse_Target_FTN; 00804 00805 /* Enter the global symbols into the symbol table, since that 00806 * ensures these get the first priority at keeping their names 00807 * unchanged (note that a w2f invented name-suffix is added to 00808 * disambiguate names). Note that we can only emit 00809 * declarations locally to PUs for Fortran, but we can still 00810 * keep a global symbol-table for naming purposes. 00811 */ 00812 Stab_initialize_flags(); 00813 00814 W2CF_Symtab_Push(); /* Push global (i.e. first ) symbol table */ 00815 W2F_Enter_Global_Symbols(); 00816 00817 /* Initiate the various W2F modules. 00818 */ 00819 reset_WN2F_CONTEXT(Global_Context); 00820 ST2F_initialize(); 00821 PUinfo_initialize(); 00822 WN2F_initialize(); 00823 00824 W2F_Initialized = TRUE; 00825 Diag_Set_Phase(caller_err_phase); 00826 } /* W2F_Init */ 00827 00828 00829 void 00830 W2F_Push_PU(WN *pu, WN *body_part_of_interest) 00831 { 00832 if (!Check_Initialized("W2F_Push_PU")) 00833 return; 00834 00835 Is_True(WN_opcode(pu) == OPC_FUNC_ENTRY, 00836 ("Invalid opcode for W2F_Push_PU()")); 00837 00838 Stab_initialize(); 00839 Clear_w2fc_flags() ; 00840 00841 /* Set up the parent mapping 00842 */ 00843 MEM_POOL_Push(&W2F_Parent_Pool); 00844 W2CF_Parent_Map = WN_MAP_Create(&W2F_Parent_Pool); 00845 W2CF_Parentize(pu); 00846 00847 00848 /* See if the body_part_of_interest has any part to be skipped 00849 * by the w2f translator. 00850 */ 00851 if (WN_opc_operator(body_part_of_interest) == OPR_BLOCK) 00852 { 00853 Remove_Skips(body_part_of_interest, 00854 Skip, 00855 &Next_Skip_Item, 00856 W2F_MAX_SKIP_ITEMS, 00857 FALSE /*Not C*/); 00858 } 00859 00860 /* Get the current PU name and ST. 00861 */ 00862 PUinfo_init_pu(pu, body_part_of_interest); 00863 } /* W2F_Push_PU */ 00864 00865 00866 void 00867 W2F_Pop_PU(void) 00868 { 00869 if (!Check_Initialized("W2F_Pop_PU") || 00870 !Check_PU_Pushed("W2F_Pop_PU")) 00871 return; 00872 00873 PUinfo_exit_pu(); 00874 00875 /* Restore any removed statement sequence 00876 */ 00877 if (Next_Skip_Item > 0) 00878 { 00879 Restore_Skips(Skip, Next_Skip_Item, FALSE /*Not C*/); 00880 Next_Skip_Item = 0; 00881 } 00882 00883 Stab_finalize(); 00884 00885 WN_MAP_Delete(W2CF_Parent_Map); 00886 W2CF_Parent_Map = WN_MAP_UNDEFINED; 00887 MEM_POOL_Pop(&W2F_Parent_Pool); 00888 00889 W2F_Frequency_Map = WN_MAP_UNDEFINED; 00890 } /* W2F_Pop_PU */ 00891 00892 00893 void 00894 W2F_Mark_Loads(void) 00895 { 00896 W2F_Only_Mark_Loads = TRUE; 00897 } /* W2F_Mark_Loads */ 00898 00899 00900 void 00901 W2F_Nomark_Loads(void) 00902 { 00903 W2F_Only_Mark_Loads = FALSE; 00904 } /* W2F_Nomark_Loads */ 00905 00906 00907 void 00908 W2F_Set_Prompf_Emission(WN_MAP *construct_map) 00909 { 00910 W2F_Prompf_Emission = TRUE; 00911 W2F_Construct_Map = construct_map; /* Construct id mapping for prompf */ 00912 } /* W2F_Set_Prompf_Emission */ 00913 00914 00915 void 00916 W2F_Set_Frequency_Map(WN_MAP frequency_map) 00917 { 00918 W2F_Frequency_Map = frequency_map; /* Feedback frequency mapping for wopt */ 00919 } /* W2F_Set_Frequency_Map */ 00920 00921 00922 const char * 00923 W2F_Get_Transformed_Src_Path(void) 00924 { 00925 return W2F_File_Name[W2F_FTN_FILE]; 00926 } /* W2F_Get_Transformed_Src_Path */ 00927 00928 00929 void 00930 W2F_Set_Purple_Emission(void) 00931 { 00932 W2F_Purple_Emission = TRUE; 00933 } /* W2F_Set_Purple_Emission */ 00934 00935 00936 void 00937 W2F_Reset_Purple_Emission(void) 00938 { 00939 W2F_Purple_Emission = FALSE; 00940 } /* W2C_Reset_Purple_Emission */ 00941 00942 00943 void 00944 W2F_def_ST(FILE *outfile, ST *st) 00945 { 00946 TOKEN_BUFFER tokens; 00947 00948 if (!Check_Initialized("W2F_def_ST")) 00949 return; 00950 00951 tokens = New_Token_Buffer(); 00952 ST2F_decl_translate(tokens, st); 00953 Write_And_Reclaim_Tokens(outfile, W2F_File[W2F_LOC_FILE], &tokens); 00954 W2F_Undo_Whirl_Side_Effects(); 00955 } /* W2F_def_ST */ 00956 00957 00958 const char * 00959 W2F_Object_Name(ST *func_st) 00960 { 00961 return W2CF_Symtab_Nameof_St(func_st); 00962 } /* W2F_Object_Name */ 00963 00964 00965 void 00966 W2F_Translate_Stid_Lhs(char *strbuf, 00967 UINT bufsize, 00968 ST *stid_st, 00969 STAB_OFFSET stid_ofst, 00970 TY_IDX stid_ty, 00971 TYPE_ID stid_mtype) 00972 { 00973 TOKEN_BUFFER tokens; 00974 WN2F_CONTEXT context = INIT_WN2F_CONTEXT; 00975 00976 tokens = New_Token_Buffer(); 00977 if (ST_class(stid_st) == CLASS_PREG) 00978 { 00979 ST2F_Use_Preg(tokens, ST_type(stid_st), stid_ofst); 00980 } 00981 else 00982 { 00983 WN2F_Offset_Symref(tokens, 00984 stid_st, /* base-symbol */ 00985 Stab_Pointer_To(ST_type(stid_st)), /* base-type */ 00986 stid_ty, /* object-type */ 00987 stid_ofst, /* object-ofst */ 00988 context); 00989 } 00990 Str_Write_And_Reclaim_Tokens(strbuf, bufsize, &tokens); 00991 W2F_Undo_Whirl_Side_Effects(); 00992 } /* W2F_Translate_Stid_Lhs */ 00993 00994 00995 void 00996 W2F_Translate_Istore_Lhs(char *strbuf, 00997 UINT bufsize, 00998 WN *lhs, 00999 STAB_OFFSET istore_ofst, 01000 TY_IDX istore_addr_ty, 01001 TYPE_ID istore_mtype) 01002 { 01003 TOKEN_BUFFER tokens; 01004 TY_IDX base_ty; 01005 WN2F_CONTEXT context = INIT_WN2F_CONTEXT; 01006 01007 /* Get the base address into which we are storing a value */ 01008 base_ty = WN_Tree_Type(lhs); 01009 if (!TY_Is_Pointer(base_ty)) 01010 base_ty = istore_addr_ty; 01011 01012 /* Get the lhs of the assignment (dereference address) */ 01013 tokens = New_Token_Buffer(); 01014 WN2F_Offset_Memref(tokens, 01015 lhs, /* base-symbol */ 01016 base_ty, /* base-type */ 01017 TY_pointed(istore_addr_ty), /* object-type */ 01018 istore_ofst, /* object-ofst */ 01019 context); 01020 Str_Write_And_Reclaim_Tokens(strbuf, bufsize, &tokens); 01021 W2F_Undo_Whirl_Side_Effects(); 01022 } /* W2F_Translate_Istore_Lhs */ 01023 01024 01025 void 01026 W2F_Translate_Wn(FILE *outfile, WN *wn) 01027 { 01028 TOKEN_BUFFER tokens; 01029 WN2F_CONTEXT context = INIT_WN2F_CONTEXT; 01030 const char * const caller_err_phase = Get_Error_Phase (); 01031 01032 if (!Check_Initialized("W2F_Translate_Wn") || 01033 !Check_PU_Pushed("W2F_Translate_Wn")) 01034 return; 01035 01036 Start_Timer(T_W2F_CU); 01037 if (W2F_Progname != NULL) 01038 Diag_Set_Phase(W2F_Progname); 01039 else 01040 Diag_Set_Phase("FLIST"); 01041 01042 tokens = New_Token_Buffer(); 01043 (void)WN2F_translate(tokens, wn, context); 01044 Write_And_Reclaim_Tokens(outfile, W2F_File[W2F_LOC_FILE], &tokens); 01045 W2F_Undo_Whirl_Side_Effects(); 01046 01047 Stop_Timer (T_W2F_CU); 01048 Diag_Set_Phase(caller_err_phase); 01049 } /* W2F_Translate_Wn */ 01050 01051 01052 void 01053 W2F_Translate_Wn_Str(char *strbuf, UINT bufsize, WN *wn) 01054 { 01055 TOKEN_BUFFER tokens; 01056 WN2F_CONTEXT context = INIT_WN2F_CONTEXT; 01057 const char * const caller_err_phase = Get_Error_Phase (); 01058 01059 if (!Check_Initialized("W2F_Translate_Wn_Str") || 01060 !Check_PU_Pushed("W2F_Translate_Wn_Str")) 01061 return; 01062 01063 Start_Timer (T_W2F_CU); 01064 if (W2F_Progname != NULL) 01065 Diag_Set_Phase(W2F_Progname); 01066 else 01067 Diag_Set_Phase("FLIST"); 01068 01069 tokens = New_Token_Buffer(); 01070 (void)WN2F_translate(tokens, wn, context); 01071 Str_Write_And_Reclaim_Tokens(strbuf, bufsize, &tokens); 01072 W2F_Undo_Whirl_Side_Effects(); 01073 01074 Stop_Timer (T_W2F_CU); 01075 Diag_Set_Phase(caller_err_phase); 01076 } /* W2F_Translate_Wn_Str */ 01077 01078 01079 void 01080 W2F_Translate_Purple_Main(FILE *outfile, WN *pu, const char *region_name) 01081 { 01082 TOKEN_BUFFER tokens; 01083 WN2F_CONTEXT context = INIT_WN2F_CONTEXT; 01084 const char * const caller_err_phase = Get_Error_Phase (); 01085 01086 if (!Check_Initialized("W2F_Translate_Purple_Main")) 01087 return; 01088 01089 Is_True(WN_opcode(pu) == OPC_FUNC_ENTRY, 01090 ("Invalid opcode for W2F_Translate_Purple_Main()")); 01091 01092 Start_Timer (T_W2F_CU); 01093 Set_Error_Phase ("WHIRL To F"); 01094 01095 /* Translate the function header as a purple main program 01096 */ 01097 tokens = New_Token_Buffer(); 01098 W2F_Push_PU(pu, WN_func_body(pu)); 01099 (void)WN2F_translate_purple_main(tokens, pu, region_name, context); 01100 W2F_Pop_PU(); 01101 W2F_Undo_Whirl_Side_Effects(); 01102 Write_And_Reclaim_Tokens(outfile, W2F_File[W2F_LOC_FILE], &tokens); 01103 01104 Stop_Timer (T_W2F_CU); 01105 Set_Error_Phase (caller_err_phase); 01106 } /* W2F_Translate_Purple_Main */ 01107 01108 01109 void 01110 W2F_Fini(void) 01111 { 01112 /* Ignore this call if W2F_Outfile_Initialized, since a call to 01113 * W2F_Outfile_Fini() must take care of the finalization for 01114 * this case. 01115 */ 01116 INT i; 01117 01118 if (!Check_Initialized("W2F_Fini")) 01119 return; 01120 else if (!W2F_Outfile_Initialized) 01121 { 01122 01123 ST2F_finalize(); 01124 PUinfo_finalize(); 01125 WN2F_finalize(); 01126 W2CF_Symtab_Terminate(); 01127 Stab_finalize_flags(); 01128 01129 if (W2F_File_Name[W2F_LOC_FILE] != NULL) 01130 End_Locations_File(); /* Writes filenames-table to file */ 01131 else 01132 Terminate_Token_Buffer(NULL); 01133 Diag_Exit(); 01134 01135 /* Reset all global variables */ 01136 01137 W2F_Initialized = FALSE; 01138 W2F_Format_Kind =F77_ANSI_FORMAT; 01139 reset_WN2F_CONTEXT(Global_Context); 01140 W2F_Progname = ""; 01141 for (i=0;i<W2F_NUM_FILES;i++) W2F_File_Name[i] = NULL; 01142 for (i=0;i<W2F_NUM_FILES;i++) File_Is_Created[i] = FALSE; 01143 for (i=0;i<W2F_NUM_FILES;i++) W2F_File[i] = NULL; 01144 W2F_Enabled = TRUE; /* Invoke W2F */ 01145 W2F_Verbose = TRUE; /* Show translation information */ 01146 W2F_Old_F77 = FALSE; /* Use macros for new intrinsics */ 01147 W2F_Ansi_Format = TRUE; 01148 W2F_No_Pragmas = FALSE; /* By default, emit pragmas */ 01149 W2F_Emit_Prefetch = FALSE; /* Emit comments for prefetches */ 01150 W2F_Emit_All_Regions = FALSE;/* Emit cmplr-generated regions */ 01151 W2F_Emit_Linedirs = FALSE; /* Emit preproc line-directives */ 01152 W2F_Emit_Nested_PUs = TRUE; 01153 W2F_Emit_Frequency = FALSE; /* Emit feedback frequency info */ 01154 W2F_Line_Length = 0; /* 'zero' means: use the default */ 01155 01156 W2F_Only_Mark_Loads = FALSE; 01157 01158 MEM_POOL_Pop(&W2F_Parent_Pool); 01159 MEM_POOL_Delete(&W2F_Parent_Pool); 01160 } /* if (initialized) */ 01161 } /* W2F_Fini */ 01162 01163 01164 /* ================================================================= 01165 * EXPORTED OUTPUT-FILE INTERFACE 01166 * ------------------------------ 01167 * 01168 * This is the easiest interface for using whirl2f.so, and it 01169 * maintains output file status and produces a uniform output 01170 * format based on the -FLIST options. There are strict rules 01171 * as to how this interface interacts with the lower-level 01172 * interface described above (see .h file for details). 01173 * 01174 * W2F_Outfile_Init() 01175 * Initializes the output-files for whirl2f, based on the 01176 * command-line options. Will call W2F_Init() is this has 01177 * not already been done. 01178 * 01179 * W2F_Outfile_Translate_Pu() 01180 * Translates a PU, presupposing W2F_Outfile_Init() has been 01181 * called. The PU will be lowered (for Fortran) and the 01182 * output Fortran code will be appended to the output files. 01183 * 01184 * W2F_Output_Fini() 01185 * Finalizes a W2F translation by closing the output-files, and 01186 * calling W2F_Fini(). 01187 * 01188 * ================================================================= 01189 */ 01190 01191 void 01192 W2F_Outfile_Init(void) 01193 { 01194 /* Initialize the various whirl2f subcomponents. It is not 01195 * always desirable to open a .h file for global declarations, 01196 * and this can be suppressed (no global declarations will be 01197 * emitted) by passing emit_global_decls=FALSE. For even more 01198 * control over the W2F translation process, use the lower-level 01199 * translation routines, instead of this more abstract 01200 * interface. 01201 */ 01202 time_t systime; 01203 01204 if (W2F_Outfile_Initialized) 01205 return; /* Already initialized */ 01206 01207 W2F_Outfile_Initialized = TRUE; 01208 if (W2F_Verbose && !W2F_OpenAD) 01209 { 01210 if (W2F_Prompf_Emission || W2F_File_Name[W2F_LOC_FILE] == NULL) 01211 fprintf(stderr, 01212 "%s translates %s into %s, based on source %s\n", 01213 W2F_Progname, 01214 Irb_File_Name, 01215 W2F_File_Name[W2F_FTN_FILE], 01216 W2F_File_Name[W2F_ORIG_FILE]); 01217 else 01218 fprintf(stderr, 01219 "%s translates %s into %s and %s, based on source %s\n", 01220 W2F_Progname, 01221 Irb_File_Name, 01222 W2F_File_Name[W2F_FTN_FILE], 01223 W2F_File_Name[W2F_LOC_FILE], 01224 W2F_File_Name[W2F_ORIG_FILE]); 01225 } /* if verbose */ 01226 01227 /* Initialize the whirl2f modules! 01228 */ 01229 if (!W2F_Initialized) 01230 W2F_Init(); 01231 01232 /* Open the output files (and write location mapping header). 01233 */ 01234 Begin_New_Locations_File(); 01235 Open_W2f_Output_File(W2F_FTN_FILE); 01236 01237 if (!W2F_OpenAD) { 01238 /* Write out a header-comment into the whirl2f generated 01239 * source file. 01240 */ 01241 systime = time(NULL); 01242 Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE], 01243 "C ********************************************" 01244 "***************\n" 01245 "C Fortran file translated from WHIRL "); 01246 Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE], 01247 ((systime != (time_t)-1)? 01248 ctime(&systime) : "at unknown time\n")); 01249 Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE], 01250 "C **********************************************" 01251 "*************\n"); 01252 } 01253 if (W2F_Old_F77) 01254 { 01255 Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE], 01256 "C Include builtin operators " 01257 "(TODO: add missing ones into this included file)\n" 01258 "#include <whirl2f.h>\n\n"); 01259 } 01260 01261 W2F_Outfile_Initialized = TRUE; 01262 01263 /* In unparsed code adding a module named " w2f__types" to solve 01264 * the real kind problem. 01265 * by defining a bounch of integer parameter to give different kinds 01266 * names,by calling intrinsic functions 01267 * selected_int_kind 01268 * selected_real_kind 01269 * to set the kind values 01270 */ 01271 01272 #if 0 01273 //made a included file .../Open64/osprey1.0/include/whirl2f_predef_types.f 01274 //before re-parser the generated file "*.w2f.f",you have to compile 01275 //this file first to get a module info file to be included in your 01276 //unparser code---fzhao 01277 01278 Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE], 01279 " module w2f__types\n\n"); 01280 Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE], 01281 " integer :: w2f__4, w2f__8, w2f__16\n"); 01282 Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE], 01283 " parameter (w2f__4 = kind(0.0))\n"); 01284 Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE], 01285 " parameter (w2f__8 = kind(0.0d0))\n"); 01286 Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE], 01287 " parameter (w2f__16 = selected_real_kind(p=30))\n\n"); 01288 01289 Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE], 01290 " integer :: w2f__i1, w2f__i2, w2f__i4,w2f__i8\n"); 01291 Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE], 01292 " parameter (w2f__i1 = selected_int_kind(r=2))\n"); 01293 Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE], 01294 " parameter (w2f__i2 = selected_int_kind(r=3))\n"); 01295 Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE], 01296 " parameter (w2f__i4 = selected_int_kind(r=8))\n"); 01297 Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE], 01298 " parameter (w2f__i8 = selected_int_kind(r=16))\n\n"); 01299 01300 Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE], 01301 " end module w2f__types\n"); 01302 #endif 01303 01304 if (!W2F_OpenAD) { 01305 Write_String(W2F_File[W2F_FTN_FILE], W2F_File[W2F_LOC_FILE], 01306 "C **********************************************" 01307 "*************\n"); 01308 } 01309 01310 01311 } /* W2F_Outfile_Init */ 01312 01313 01314 void 01315 W2F_Outfile_Translate_Pu(WN *pu) 01316 { 01317 TOKEN_BUFFER tokens; 01318 LOWER_ACTIONS lower_actions = LOWER_NULL; 01319 const BOOL pu_is_pushed = (PUinfo_current_func == pu); 01320 const char * const caller_err_phase = Get_Error_Phase (); 01321 01322 if (!Check_Outfile_Initialized("W2F_Outfile_Translate_Pu")) 01323 return; 01324 01325 Is_True(WN_opcode(pu) == OPC_FUNC_ENTRY, 01326 ("Invalid opcode for W2F_Outfile_Translate_Pu()")); 01327 01328 /* Make sure all necessary output files are open. 01329 */ 01330 Continue_Locations_File(); 01331 Open_W2f_Output_File(W2F_FTN_FILE); 01332 01333 if (W2F_Emit_Nested_PUs) 01334 lower_actions = LOWER_MP; 01335 01336 # if 0 01337 if (lower_actions != LOWER_NULL) 01338 pu = WN_Lower(pu, lower_actions, NULL, "W2F Lowering"); 01339 # endif 01340 01341 Start_Timer(T_W2F_CU); 01342 if (W2F_Progname != NULL) 01343 Diag_Set_Phase(W2F_Progname); 01344 else 01345 Diag_Set_Phase("FLIST"); 01346 01347 if (!pu_is_pushed) 01348 W2F_Push_PU(pu, WN_func_body(pu)); 01349 01350 /* Set the flag for an F90 program unit */ 01351 01352 PU & pucur = Pu_Table[ST_pu(PUINFO_FUNC_ST)]; 01353 WN2F_F90_pu = PU_f90_lang(pucur) != 0; 01354 01355 // indented nested f90 routines, close CONTAINS for f90, if reqd.. 01356 01357 BOOL nested = PU_is_nested_func(pucur); 01358 01359 tokens = New_Token_Buffer(); 01360 01361 if (nested) 01362 { 01363 WN2F_Emit_End_Stmt(tokens,TRUE); 01364 Increment_Indentation(); 01365 } else 01366 WN2F_Emit_End_Stmt(tokens,FALSE); 01367 01368 /* Avoid to dump out some type definitions which 01369 * do not defined in this PU--especially in nested PU 01370 * types of dummy arguments could be derived type defined 01371 * in the parent PU 01372 * --FMZ 01373 */ 01374 for (TY_IDX ty = 1; ty < TY_Table_Size(); ty++) { 01375 if (TY_kind(ty<<8)==KIND_STRUCT) 01376 Set_TY_is_translated_to_c(ty<<8); 01377 } 01378 01379 if (W2F_OpenAD) { 01380 // look ahead to find a file_start pragmas 01381 // in this PU which would be located in the beginning 01382 // of the 3rd block under the FUNC_ENTRY 01383 WN_TREE_CONTAINER<PRE_ORDER> aWNPtree(pu); 01384 WN_TREE_CONTAINER<PRE_ORDER>::iterator aWNPtreeIterator=aWNPtree.begin(); 01385 while (aWNPtreeIterator != aWNPtree.end()) { 01386 WN* curWN_p = aWNPtreeIterator.Wn(); 01387 OPERATOR opr = WN_operator(curWN_p); 01388 if (opr==OPR_PRAGMA 01389 && 01390 WN_pragma(curWN_p)==WN_PRAGMA_OPENAD_XXX 01391 && 01392 WN_has_sym(curWN_p)) { 01393 std::string pragmaName(Targ_Print(NULL, WN_val(curWN_p))); 01394 std::transform(pragmaName.begin(), 01395 pragmaName.end(), 01396 pragmaName.begin(), 01397 static_cast < int(*)(int) > (tolower)); 01398 if (pragmaName.compare(1,filePragma.length(),filePragma)==0) { 01399 // have a match 01400 // dump it 01401 Append_F77_Directive_Newline(tokens, "C$OPENAD XXX"); 01402 Append_Token_Special(tokens, ' '); 01403 Append_ST_String(tokens, curWN_p); 01404 break; 01405 } 01406 } 01407 ++aWNPtreeIterator; 01408 } 01409 } 01410 01411 (void)WN2F_translate(tokens, pu, Global_Context); 01412 Write_And_Reclaim_Tokens(W2F_File[W2F_FTN_FILE], 01413 W2F_File[W2F_LOC_FILE], 01414 &tokens); 01415 01416 if (nested) 01417 Decrement_Indentation(); 01418 01419 if (!pu_is_pushed) 01420 W2F_Pop_PU(); 01421 01422 W2F_Undo_Whirl_Side_Effects(); 01423 01424 Stop_Timer(T_W2F_CU); 01425 Diag_Set_Phase(caller_err_phase); 01426 } /* W2F_Outfile_Translate_Pu */ 01427 01428 01429 void 01430 W2F_Outfile_Fini(void) 01431 { 01432 TOKEN_BUFFER tokens; 01433 01434 /* This finalization must be complete enough to allow repeated 01435 * invocations of whirl2c during the same process life-time. 01436 */ 01437 const char *loc_fname = W2F_File_Name[W2F_LOC_FILE]; 01438 01439 if (!Check_Outfile_Initialized("W2F_Outfile_Fini")) 01440 return; 01441 01442 Clear_w2fc_flags() ; 01443 01444 // Emit END for nested routines if reqd. 01445 // Look at global symtab for initalized COMMON. 01446 01447 tokens = New_Token_Buffer(); 01448 01449 WN2F_Emit_End_Stmt(tokens,FALSE); 01450 01451 WN2F_Append_Block_Data(tokens); 01452 Write_And_Reclaim_Tokens(W2F_File[W2F_FTN_FILE], 01453 W2F_File[W2F_LOC_FILE], 01454 &tokens); 01455 01456 /* All files must be closed before doing a partial 01457 * finalization. 01458 */ 01459 Close_W2f_Output_File(W2F_FTN_FILE); 01460 W2F_Outfile_Initialized = FALSE; 01461 W2F_Fini(); /* End_Locations_File() and sets W2F_Initialized to FALSE */ 01462 01463 if (W2F_Prompf_Emission && loc_fname != NULL) 01464 { 01465 /* Copy the locations file to the .anl file and remove it 01466 */ 01467 Move_Locations_To_Anl_File(loc_fname); 01468 } 01469 } /* W2F_Outfile_Fini */ 01470 01471 01472 void 01473 W2F_Cleanup(void) 01474 { 01475 /* Cleanup in case of error condition (or a forgotten call to Anl_Fini()) 01476 */ 01477 Close_W2f_Output_File(W2F_LOC_FILE); 01478 Close_W2f_Output_File(W2F_FTN_FILE); 01479 if (W2F_File_Name[W2F_LOC_FILE] != NULL) 01480 unlink(W2F_File_Name[W2F_LOC_FILE]); 01481 }