russell: C:/Users/Dennis/src/lang/russell.orig/src/pass5d/find

00001 # include "parm.h"
00002 # include <stdio.h>
00003 
00004 # include "stree/ststructs.mh"
00005 
00006 # include "pass5d/op_codes.h"
00007 
00008 # include "pass5d/codegen.h"
00009 
00010 extern char str_code_buf[];
00011 
00012 extern boolean Tflag;  /* Generate trace code */
00013 
00014 extern boolean Oflag;  /* Produce fast code, sacrificing compiler speed */
00015                        /* and space as necessary.                       */
00016 
00017 extern boolean Vflag;  /* Verbose: report successful optimizations */
00018 
00019 extern FILE * unparse_file;
00020 
00021 extern long int_const_val;  /* Set by is_int_const */
00022 
00023 char * construct_inline();  /* Really returns sequence of RIC instructions */
00024 
00025 char * Ginline_cnvt();  /* Not really a character pointer, but ... */
00026 
00027 # define MAXINLINELEN 20    /* longer sequences will not be incorporated into */
00028                             /* other sequences.                               */
00029 
00030 /* CURRENTLY RATHER PRIMITIVE */
00031 
00032 /* Fill in the fsig_inline_code field in the function construction fc */
00033 /* if possible.  Assumes that signatures inside body are known.       */
00034 
00035 void Gfind_inline(fc)
00036 NODE * fc;
00037 {
00038     NODE * fsig = fc -> signature;
00039     NODE * body = fc -> fc_body;
00040     int code_len = 0;
00041     char * code;
00042     int n_percents = 0;   /* number of percent signs in inline code */
00043     NODE * p;
00044     int i;
00045 
00046 #   ifdef DEBUG
00047         if (fc -> kind != FUNCCONSTR) {
00048             dbgmsg("find_inline: bad function construction\n");
00049         }
00050 #   endif
00051     /* printf("find_inline: %s\n", fc -> fc_code_label); */
00052     if (fsig -> fsig_inline_code != NIL) return;
00053     if (body -> kind == EXTERNDEF) {
00054         int nargs = length(fsig -> fsig_param_list)
00055                     - n_vacuous_params(fsig -> fsig_param_list);
00056         char buf[MAXSTRCODELEN];
00057         extern boolean vacuous_arg();
00058 
00059         if (10 * nargs + 2*strlen(body -> ext_name) + 50 > MAXSTRCODELEN) {
00060             /* Might overflow buffer */
00061             return;
00062         }
00063         str_code_buf[0] = '\0';
00064         for (i = nargs; i >= 1; i--) {
00065             sprintf(buf, "ARG %d,$%d;", i, i);
00066             strcat(str_code_buf, buf);
00067         };
00068         sprintf(buf, "EXT \"%s\"; LBA \"%s\"; CLC %d;",
00069                 body -> ext_name, body -> ext_name, nargs);
00070         strcat(str_code_buf, buf);
00071         strcat(str_code_buf, "MOV RL,RS");
00072         fsig -> fsig_inline_code = Ginline_cnvt(str_code_buf);
00073         return;
00074     }
00075     if (Tflag) {
00076         /* In-line expansion would hinder tracing */
00077         return;
00078     }
00079     /* Construct in-line code for the body, if possible. */
00080         if (Oflag) {
00081             fsig -> fsig_inline_code = construct_inline(body, RS, fc);
00082             if (Vflag && fsig -> fsig_inline_code != NIL) {
00083                 printf("Constructed in-line code sequence for: ");
00084                 if (fc -> fc_code_label == NIL) {
00085                     unparse_file = stdout;
00086                     unparse(fc);
00087                     printf("\n");
00088                 } else {
00089                     printf("%s\n", fc -> fc_code_label);
00090                 }
00091             }
00092         }
00093     return;
00094 }
00095 
00096 /* Construct in-line code for the expression expr occuring in the body */
00097 /* of the function fc.  The in-line code leaves the resulting value in */
00098 /* rloc.  Returns NIL if things get too messy.                         */
00099 char * construct_inline(expr,rloc,fc)
00100 NODE * expr;
00101 long rloc;
00102 NODE * fc;
00103 {
00104     extern long avail_loc;
00105     int param_num;
00106     NODE * params;
00107     extern boolean vacuous_arg();
00108     static char buf[50];
00109 
00110     if (is_int_const(expr)) {
00111         sprintf(buf, "LDN %d,%d", int_const_val, rloc);
00112         return(Ginline_cnvt(buf));
00113     }
00114     switch(expr -> kind) {
00115         case OPRID:
00116         case LETTERID:
00117             if (expr -> sel_type != NIL
00118                 || expr -> id_last_definition -> kind != PARAMETER
00119                 || expr -> id_last_definition -> par_scope != fc) {
00120                 return(NIL);
00121             }
00122             if (vacuous_arg(expr -> signature)) {
00123                 sprintf(buf, "HINT OPT,1; MOV UN,%d", rloc);
00124                 return(Ginline_cnvt(buf));
00125             }
00126             /* Find the position of the parameter in the parameter list */
00127                 params = fc -> signature -> fsig_param_list;
00128                 param_num = 1;
00129                 maplist(s, params, {
00130                     if (s -> pre_num ==
00131                         expr -> id_last_definition -> pre_num) {
00132                         break;
00133                     }
00134                     /* Must be explicitly passed, since the one we're */
00135                     /* looking for is not vacuous, and it follows.    */
00136                     param_num++;
00137                 });
00138                 sprintf(buf, "MOV $%d,%d", param_num, rloc);
00139                 return(Ginline_cnvt(buf));
00140             break;
00141 
00142         case BLOCKDENOTATION:
00143             if (length(expr -> bld_den_seq) != 1) {
00144                 return(NIL);
00145             }
00146             maplist (s, expr -> bld_declaration_list, {
00147                 if (eval_decl(s) && !is_int_const(s -> decl_denotation)) {
00148                     /* We'd have to include code for r.h.s. */
00149                     return(NIL);
00150                     /* Other declarations are still likely to cause this */
00151                     /* to fail, since we can't compile references to the */
00152                     /* identifiers.  But simple function or type decls   */
00153                     /* and integer constants are OK.                     */
00154                 }
00155             });
00156             return(construct_inline(first(expr -> bld_den_seq), rloc, fc));
00157 
00158         case APPLICATION:
00159             {
00160                 NODE * op_sig = expr -> ap_operator -> signature;
00161                 struct RIC_instr * inline_code = NIL;
00162                 struct RIC_instr * operator_code;
00163                 struct RIC_instr * udc_code;
00164                 NODE * args = expr -> ap_args;
00165                 int nargs;
00166                 int c_arg;  /* position of current arg, 0 = leftmost */
00167                 extern long avail_loc;
00168                 long first_loc = avail_loc; /* loc for first argument */
00169                 int i;
00170 
00171                 if (op_sig -> fsig_inline_code == NIL) {
00172                     return(NIL);
00173                 }
00174                 if (RIC_len(op_sig -> fsig_inline_code) > MAXINLINELEN) {
00175                     return(NIL);
00176                 }
00177                 nargs = 0;
00178                 i = 0;
00179                 maplist(s, args, {
00180                     i++;
00181                     if (!vacuous_arg(s -> signature)) {
00182                         nargs = i;
00183                     }
00184                 });
00185                 avail_loc += nargs;
00186                 c_arg = 0;
00187                 /* Build in-line code for arguments */
00188                   maplist(s, args, {
00189                     if (c_arg < nargs) {
00190                         char * arg_code;
00191                         arg_code = construct_inline(s, first_loc + c_arg, fc);
00192                         if (arg_code == NIL) {
00193                             free_RIC(inline_code);
00194                             return(NIL);
00195                         }
00196                         inline_code = cat_RIC(arg_code, inline_code);
00197                     }
00198                     c_arg++;
00199                   });
00200                 /* Add declarations for argument locations */
00201                   for (i = 0; i < nargs; i++) {
00202                     sprintf(buf, "DCL %d,INT", first_loc + i);
00203                     inline_code = cat_RIC(Ginline_cnvt(buf), inline_code);
00204                   }
00205                 /* Build operator code */
00206                   operator_code = copy_RIC(op_sig -> fsig_inline_code);
00207                   operator_code = RIC_inst_args(operator_code, first_loc);
00208                   operator_code = RIC_inst_rs(operator_code, rloc);
00209                 /* build undeclare instructions */
00210                   udc_code = NIL;
00211                   for (i = 0; i < nargs; i++) {
00212                     sprintf(buf, "UDC %d", first_loc + i);
00213                     udc_code = cat_RIC(Ginline_cnvt(buf), udc_code);
00214                   }
00215                 operator_code = cat_RIC(operator_code, udc_code);
00216                 inline_code = cat_RIC(inline_code, operator_code);
00217                 return((char *)inline_code);
00218             }
00219             break;
00220         default:
00221             return(NIL);
00222     }
00223 }
00224 
00225 
00226 /* Convert the special function descriptor from function signature to */
00227 /* inline code.                                                       */
00228 /* Clobbers str_code_buf                                              */
00229 char * Gspcl_to_inline(spcl)
00230 unsigned spcl;
00231 {
00232 #   define MAX_PROD_EXP_LEN 10
00233     int tp = special_tp(spcl);
00234     int val = special_val(spcl);
00235     int i;
00236     char * result;
00237 
00238     str_code_buf[0] = '\0';
00239     switch(tp) {
00240         case PROD_NEW:
00241         case UNION_NEW:
00242         case ENUM_NEW:
00243             sprintf(str_code_buf, "ALH C1,RS; STI RS,0,C0");
00244             break;
00245         case PROD_ASSIGN:
00246         case UNION_ASSIGN:
00247         case ENUM_ASSIGN:
00248             strcpy(str_code_buf, "STI $1,0,$2; MOV $2,RS");
00249             break;
00250         case PROD_VALUEOF:
00251         case UNION_VALUEOF:
00252         case ENUM_VALUEOF:
00253             strcpy(str_code_buf, "LDI $1,0,RS");
00254             break;
00255         case PROD_MK:
00256             if (val > MAX_PROD_EXP_LEN) return(NIL);
00257             switch(val) {
00258               case 1:
00259                 strcpy(str_code_buf, "ALH C1,T1;");
00260                 break;
00261               case 2:
00262                 strcpy(str_code_buf, "ALH C2,T1;");
00263                 break;
00264               default:
00265                 sprintf(str_code_buf,
00266                         "LDN %d,T1; ALH T1,T1;",
00267                         val);
00268                 break;
00269             }
00270             for(i = 0; i < val; i++) {
00271                 char buf[50];
00272                 sprintf(buf, "STI T1,%d,$%d;", i, i+1);
00273                 strcat(str_code_buf, buf);
00274             }
00275             strcat(str_code_buf, "MOV T1,RS");
00276             break;
00277         case PROD_PROJ:
00278         case RECORD_VAL_FIELD:
00279         case RECORD_VAR_FIELD:
00280             sprintf(str_code_buf, "LDI $1,%d,RS", val);
00281             break;
00282         case UNION_INJ:
00283             switch(val) {
00284               case 0:
00285                 sprintf(str_code_buf,
00286                         "ALH C2,T1; STI T1,0,$1; STI T1,1,C0; MOV T1,RS");
00287                 break;
00288               case 1:
00289                 sprintf(str_code_buf,
00290                         "ALH C2,T1; STI T1,0,$1; STI T1,1,C1; MOV T1,RS");
00291                 break;
00292               case 2:
00293                 sprintf(str_code_buf,
00294                         "ALH C2,T1; STI T1,0,$1; STI T1,1,C2; MOV T1,RS");
00295                 break;
00296               case 3:
00297                 sprintf(str_code_buf,
00298                         "ALH C2,T1; STI T1,0,$1; STI T1,1,C3; MOV T1,RS");
00299                 break;
00300               default:
00301                 sprintf(str_code_buf,
00302                         "ALH C2,T1; STI T1,0,$1; DCL T2,INT; LDN %d,T2; STI T1,1,T2; UDC T2; MOV T1,RS",
00303                         val);
00304                 break;
00305             }
00306             break;
00307         case UNION_INJ0:
00308             /* Same thing, but with a vacuous argument */
00309             sprintf(str_code_buf,
00310                     "ALH C2,T1; DCL T2,INT; LDN %d,T2; STI T1,1,T2; UDC T2; MOV T1,RS",
00311                     val);
00312             break;
00313         case UNION_INQ:
00314             sprintf(str_code_buf, "DCL T2,INT; LDI $1,1,T2; LDN %d,T1; EQI T1,T2,RS; UDC T2", val);
00315             break;
00316         case UNION_PROJ:
00317             /* Should be improved ... */
00318             if (val <= 4) {
00319                 sprintf(str_code_buf, "HINT OPT,6; LDI $1,1,T1; EQI C%d,T1,TL; BRT \"1f\"; EXT \"_union_err\"; ERR \"_union_err\"; LBL \"1\"; LDI $1,0,RS", val);
00320             } else {
00321                 sprintf(str_code_buf, "DCL T2,INT; HINT OPT,7; LDN %d,T2; LDI $1,1,T1; EQI T2,T1,TL; BRT \"1f\"; EXT \"_union_err\"; ERR \"_union_err\"; LBL \"1\"; UDC T2; LDI $1,0,RS", val);
00322             }
00323             break;
00324         case ENUM_EQ:
00325             strcpy(str_code_buf, "EQI $1,$2,RS");
00326             break;
00327         case ENUM_NE:
00328             strcpy(str_code_buf, "NEI $1,$2,RS");
00329             break;
00330         case ENUM_CARD:
00331         case ENUM_ELEMENT:
00332             sprintf(str_code_buf, "LDN %d RS", val);
00333             break;
00334         case IDENTITY:
00335             strcpy(str_code_buf, "MOV $1,RS");
00336             break;
00337         case ENUM_PRED:
00338             sprintf(str_code_buf, "HINT OPT,5; GTI $1,C0,TL; BRT \"1f\"; EXT \"_pred_error\"; ERR \"_pred_error\"; LBL \"1\"; SBI $1,C1,RS");
00339             break;
00340         case ENUM_SUCC:
00341             /* Should be improved ... */
00342             sprintf(str_code_buf, "HINT OPT,6; LDN %d,T1; LTI $1,T1,TL; BRT \"1f\"; EXT \"_succ_error\"; ERR \"_succ_error\"; LBL \"1\"; ADI $1,C1,RS", val-1);
00343             break;
00344         case UNDEF_CONST:
00345             sprintf(str_code_buf, "MOV UN,RS");
00346             break;
00347         default:
00348             return(NIL);
00349     }
00350     /* symbolic representation of code is in str_code_buf */
00351     return(Ginline_cnvt(str_code_buf));
00352 }
C:/Users/Dennis/src/lang/russell.orig/src/pass5d/find_inline.c
