src/basesuif/fixfortran/inline.cc

   1 /* file "inline.cc" of the fixfortran program for SUIF */
   2
   3 /*  Copyright (c) 1994 Stanford University
   4
   5     All rights reserved.
   6
   7     This software is provided under the terms described in
   8     the "suif_copyright.h" include file. */
   9
  10 #include <suif_copyright.h>
  11
  12 /*
  13  *  This file contains code to inline some calls to Fortran
  14  *  intrinsics.
  15  */
  16
  17 #define RCS_BASE_FILE inline_cc
  18
  19 #include "fixfortran.h"
  20 #include <string.h>
  21
  22 RCS_BASE(
  23     "$Id: inline.cc,v 1.1.1.1 1998/06/16 15:17:24 brm Exp $")
  24
  25 /*----------------------------------------------------------------------*
  26     Begin Type Declarations
  27  *----------------------------------------------------------------------*/
  28
  29 /*----------------------------------------------------------------------*
  30     End Type Declarations
  31  *----------------------------------------------------------------------*/
  32 /*----------------------------------------------------------------------*
  33     Begin Private Function Declarations
  34  *----------------------------------------------------------------------*/
  35
  36 static void inline_complex_part_call(in_cal *the_call, int part, int size);
  37 static void inline_complex_exp(in_cal *the_call, type_node *elem_type);
  38 static void inline_complex_conjugate(in_cal *the_call);
  39 static proc_sym *find_math_sym(char *fast_name, char *base_name);
  40
  41 /*----------------------------------------------------------------------*
  42     End Private Function Declarations
  43  *----------------------------------------------------------------------*/
  44 /*----------------------------------------------------------------------*
  45     Begin Public Function Implementations
  46  *----------------------------------------------------------------------*/
  47
  48 /*
  49  *  Inlines fortran MAX, MIN, and ABS calls.
  50  */
  51 extern void inline_intrinsics_on_instr(instruction *the_instr, void *)
  52   {
  53     if (the_instr->format() != inf_cal)
  54         return;
  55
  56     in_cal *the_call = (in_cal *)the_instr;
  57
  58     sym_node *address_symbol = proc_for_call(the_call);
  59     if (address_symbol == NULL)
  60         return;
  61
  62     const char *name = address_symbol->name();
  63
  64     if ((strcmp(name, "pow_ii") == 0) || (strcmp(name, "pow_dd") == 0))
  65       {
  66         if (the_call->num_args() != 2)
  67             return;
  68         char *new_name;
  69         if (strcmp(name, "pow_ii") == 0)
  70             new_name = "fr_power_i_i";
  71         else
  72             new_name = "fr_power_d_d";
  73         operand arg1 = the_call->argument(0);
  74         operand arg2 = the_call->argument(1);
  75         type_node *arg_type1 = arg1.type();
  76         type_node *arg_type2 = arg2.type();
  77         if ((!arg_type1->is_ptr()) || (!arg_type2->is_ptr()))
  78             return;
  79         ptr_type *ptr1 = (ptr_type *)arg_type1;
  80         ptr_type *ptr2 = (ptr_type *)arg_type2;
  81         type_node *base1 = ptr1->ref_type();
  82         type_node *base2 = ptr2->ref_type();
  83         if (((base1->op() != TYPE_INT) && (base1->op() != TYPE_FLOAT)) ||
  84             ((base2->op() != TYPE_INT) && (base2->op() != TYPE_FLOAT)))
  85           {
  86             return;
  87           }
  88         proc_sym *new_proc = fileset->globals()->lookup_proc(new_name);
  89         if (new_proc == NULL)
  90           {
  91             if ((base1->parent() != fileset->globals()) ||
  92                 (base2->parent() != fileset->globals()) ||
  93                 (the_call->result_type()->parent() != fileset->globals()))
  94               {
  95                 return;
  96               }
  97             func_type *new_func_type =
  98                     new func_type(the_call->result_type(), base1, base2);
  99             new_func_type =
 100                     (func_type *)(fileset->globals()->install_type(
 101                                           new_func_type));
 102             new_proc =
 103                     fileset->globals()->new_proc(new_func_type, src_unknown,
 104                                                  new_name);
 105             new_proc->append_annote(k_fortran_power_op);
 106             new_proc->append_annote(k_pure_function);
 107           }
 108         operand old_addr_op = the_call->addr_op();
 109         old_addr_op.remove();
 110         kill_op(old_addr_op);
 111         the_call->set_addr_op(addr_op(new_proc));
 112         arg1.remove();
 113         arg2.remove();
 114         arg1 = fold_load(arg1);
 115         arg2 = fold_load(arg2);
 116         the_call->set_argument(0, arg1);
 117         the_call->set_argument(1, arg2);
 118         return;
 119       }
 120
 121     if_ops opcode;
 122
 123     if ((strcmp(name, "h_max") == 0) || (strcmp(name, "i_max") == 0) ||
 124         (strcmp(name, "r_max") == 0) || (strcmp(name, "d_max") == 0) ||
 125         (strcmp(name, "ri_max") == 0) || (strcmp(name, "di_max") == 0) ||
 126         (strcmp(name, "ir_max") == 0) || (strcmp(name, "id_max") == 0))
 127       {
 128         opcode = io_max;
 129       }
 130     else if ((strcmp(name, "h_min") == 0) || (strcmp(name, "i_min") == 0) ||
 131              (strcmp(name, "r_min") == 0) || (strcmp(name, "d_min") == 0) ||
 132              (strcmp(name, "ri_min") == 0) || (strcmp(name, "di_min") == 0) ||
 133              (strcmp(name, "ir_min") == 0) || (strcmp(name, "id_min") == 0))
 134       {
 135         opcode = io_min;
 136       }
 137     else if ((strcmp(name, "sd_abs") == 0) || (strcmp(name, "sr_abs") == 0) ||
 138              (strcmp(name, "si_abs") == 0) || (strcmp(name, "sh_abs") == 0))
 139       {
 140         opcode = io_abs;
 141       }
 142     else
 143       {
 144         if (strcmp(name, "d_imag") == 0)
 145             inline_complex_part_call(the_call, 1, target.size[C_double]);
 146         else if (strcmp(name, "r_imag") == 0)
 147             inline_complex_part_call(the_call, 1, target.size[C_float]);
 148         else if (strcmp(name, "c_exp") == 0)
 149             inline_complex_exp(the_call, type_float);
 150         else if (strcmp(name, "z_exp") == 0)
 151             inline_complex_exp(the_call, type_double);
 152         else if (strcmp(name, "r_cnjg") == 0)
 153             inline_complex_conjugate(the_call);
 154         else if (strcmp(name, "d_cnjg") == 0)
 155             inline_complex_conjugate(the_call);
 156         return;
 157       }
 158
 159     type_node *the_type = the_call->result_type();
 160     unsigned num_operands = the_call->num_args();
 161
 162     instruction *new_instr;
 163
 164     if (opcode == io_abs)
 165       {
 166         if (num_operands != 1)
 167           {
 168             warning_line(the_call->parent(),
 169                          "call to abs() with %d arguments can't be inlined,"
 170                          " ignoring", num_operands);
 171             return;
 172           }
 173         operand source = the_call->argument(0);
 174         source.remove();
 175         new_instr = new in_rrr(opcode, the_type, operand(), source);
 176       }
 177     else
 178       {
 179         char *function_name;
 180         if (opcode == io_max)
 181             function_name = "max";
 182         else
 183             function_name = "min";
 184         if (num_operands < 3)
 185           {
 186             warning_line(the_call->parent(),
 187                          "call to %s() with %d arguments can't be inlined,"
 188                          " ignoring", function_name, num_operands);
 189             return;
 190           }
 191
 192         operand count_operand = the_call->argument(0);
 193         boolean wrong_format = FALSE;
 194         instruction *count_instr;
 195         in_ldc *count_ldc;
 196         immed count_value;
 197         if (count_operand.kind() != OPER_INSTR)
 198             wrong_format = TRUE;
 199         if (!wrong_format)
 200           {
 201             count_instr = count_operand.instr();
 202             if (count_instr->format() != inf_ldc)
 203                 wrong_format = TRUE;
 204           }
 205         if (!wrong_format)
 206           {
 207             count_ldc = (in_ldc *)count_instr;
 208             count_value = count_ldc->value();
 209             if (!count_value.is_unsigned_int())
 210                 wrong_format = TRUE;
 211           }
 212         if (!wrong_format)
 213           {
 214             if (count_value.unsigned_int() != num_operands - 1)
 215                 wrong_format = TRUE;
 216           }
 217         if (wrong_format)
 218           {
 219             warning_line(the_call->parent(),
 220                          "the arguments to a call to %s() don't have the "
 221                          "proper form\n(an argument count followed by the "
 222                          "actual arguments), so it will not be\ninlined.",
 223                          function_name);
 224             return;
 225           }
 226
 227         operand source_1 = the_call->argument(1);
 228         source_1.remove();
 229
 230         operand source_2 = the_call->argument(2);
 231         source_2.remove();
 232
 233         type_node *computation_type = the_type;
 234         type_node *operand_type = source_1.type();
 235         if ((the_type->op() == TYPE_INT) && (operand_type->op() == TYPE_FLOAT))
 236             computation_type = operand_type;
 237
 238         source_1 = cast_op(source_1, computation_type);
 239         source_2 = cast_op(source_2, computation_type);
 240
 241         new_instr = new in_rrr(opcode, computation_type, operand(), source_1,
 242                                source_2);
 243         unsigned arg_num = 3;
 244         while (arg_num < num_operands)
 245           {
 246             source_1.set_instr(new_instr);
 247             source_2 = the_call->argument(arg_num);
 248             source_2.remove();
 249             source_2 = cast_op(source_2, computation_type);
 250             new_instr = new in_rrr(opcode, computation_type, operand(),
 251                                    source_1, source_2);
 252             ++arg_num;
 253           }
 254
 255         operand new_op = cast_op(operand(new_instr), the_type);
 256         assert(new_op.is_expr());
 257         new_instr = new_op.instr();
 258       }
 259
 260     replace_instruction(the_call, new_instr);
 261
 262     delete the_call;
 263   }
 264
 265 /*----------------------------------------------------------------------*
 266     End Public Function Implementations
 267  *----------------------------------------------------------------------*/
 268 /*----------------------------------------------------------------------*
 269     Begin Private Function Implementations
 270  *----------------------------------------------------------------------*/
 271
 272 static void inline_complex_part_call(in_cal *the_call, int part, int size)
 273   {
 274     if (the_call->num_args() != 1)
 275       {
 276         error_line(1, NULL,
 277                    "call to complex selector function with %d arguments",
 278                    the_call->num_args());
 279       }
 280
 281     operand arg_op = the_call->argument(0);
 282     arg_op.remove();
 283
 284     type_node *arg_type = arg_op.type()->unqual();
 285     if (!arg_type->is_ptr())
 286       {
 287         error_line(1, NULL,
 288                    "call to complex selector function with non-pointer "
 289                    "argument", the_call->num_args());
 290       }
 291     ptr_type *arg_ptr = (ptr_type *)arg_type;
 292     type_node *arg_base = arg_ptr->ref_type()->unqual();
 293
 294     type_node *result_type = new base_type(TYPE_FLOAT, size);
 295     result_type = fileset->globals()->install_type(result_type);
 296
 297     boolean correct_type = FALSE;
 298     if (arg_base->is_array())
 299       {
 300         array_type *arg_array = (array_type *)arg_base;
 301         if ((arg_array->elem_type() == result_type) &&
 302             (arg_array->lower_bound() == array_bound(0)) &&
 303             (arg_array->upper_bound() == array_bound(1)))
 304           {
 305             correct_type = TRUE;
 306           }
 307       }
 308
 309     if (!correct_type)
 310       {
 311         array_type *new_array =
 312                 new array_type(result_type, array_bound(0), array_bound(1));
 313         ptr_type *new_ptr =
 314                 fileset->globals()->install_type(new_array)->ptr_to();
 315         arg_op = operand(new in_rrr(io_cvt, new_ptr, operand(), arg_op));
 316       }
 317
 318     in_array *new_array = add_const_aref(arg_op, part);
 319     instruction *new_instr =
 320             new in_rrr(io_lod, result_type, operand(), operand(new_array));
 321
 322     if (the_call->result_type() != result_type)
 323       {
 324         new_instr =
 325                 new in_rrr(io_cvt, the_call->result_type(), operand(),
 326                            operand(new_instr));
 327       }
 328
 329     replace_instruction(the_call, new_instr);
 330
 331     delete the_call;
 332   }
 333
 334 static void inline_complex_exp(in_cal *the_call, type_node *elem_type)
 335   {
 336     if (!the_call->dst_op().is_null())
 337         error_line(1, the_call, "bad destination op for complex exp call");
 338     if (the_call->num_args() != 2)
 339         error_line(1, the_call, "bad arg count for complex exp call");
 340     operand result_pointer = the_call->argument(0);
 341     operand arg_pointer = the_call->argument(1);
 342     result_pointer.remove();
 343     arg_pointer.remove();
 344     operand arg_real_part =
 345             fold_load(operand(add_const_aref(arg_pointer.clone(), 0)));
 346     operand arg_imag_part = fold_load(operand(add_const_aref(arg_pointer, 1)));
 347
 348     operand result_real_pointer =
 349             operand(add_const_aref(result_pointer.clone(), 0));
 350     operand result_imag_pointer = operand(add_const_aref(result_pointer, 1));
 351
 352     tree_instr *parent = the_call->parent();
 353     var_sym *temp_var = parent->scope()->new_unique_var(type_double);
 354
 355     proc_sym *exp_sym = find_math_sym("F_exp", "exp");
 356     in_cal *exp_call =
 357             new in_cal(type_double, operand(temp_var), addr_op(exp_sym),
 358                        cast_op(arg_real_part, type_double));
 359     parent->parent()->insert_before(new tree_instr(exp_call),
 360                                     parent->list_e());
 361
 362     proc_sym *cos_sym = find_math_sym("F_cos", "cos");
 363     in_cal *cos_call =
 364             new in_cal(type_double, operand(), addr_op(cos_sym),
 365                        cast_op(arg_imag_part.clone(), type_double));
 366     in_rrr *cos_str =
 367             new in_rrr(io_str, type_void, operand(), result_real_pointer,
 368                        cast_op(operand(temp_var) * operand(cos_call),
 369                                elem_type));
 370     parent->parent()->insert_before(new tree_instr(cos_str), parent->list_e());
 371
 372     proc_sym *sin_sym = find_math_sym("F_sin", "sin");
 373     in_cal *sin_call =
 374             new in_cal(type_double, operand(), addr_op(sin_sym),
 375                        cast_op(arg_imag_part, type_double));
 376     in_rrr *sin_str =
 377             new in_rrr(io_str, type_void, operand(), result_imag_pointer,
 378                        cast_op(operand(temp_var) * operand(sin_call),
 379                                elem_type));
 380     parent->remove_instr(the_call);
 381     parent->set_instr(sin_str);
 382     delete the_call;
 383   }
 384
 385 static void inline_complex_conjugate(in_cal *the_call)
 386   {
 387     if (!the_call->dst_op().is_null())
 388         error_line(1, the_call, "bad destination op for complex exp call");
 389     if (the_call->num_args() != 2)
 390         error_line(1, the_call, "bad arg count for complex exp call");
 391     operand result_pointer = the_call->argument(0);
 392     operand arg_pointer = the_call->argument(1);
 393     result_pointer.remove();
 394     arg_pointer.remove();
 395     operand arg_real_part =
 396             fold_load(operand(add_const_aref(arg_pointer.clone(), 0)));
 397     operand arg_imag_part = fold_load(operand(add_const_aref(arg_pointer, 1)));
 398
 399     operand result_real_pointer =
 400             operand(add_const_aref(result_pointer.clone(), 0));
 401     operand result_imag_pointer = operand(add_const_aref(result_pointer, 1));
 402
 403     tree_instr *parent = the_call->parent();
 404
 405     in_rrr *copy_str =
 406             new in_rrr(io_str, type_void, operand(), result_real_pointer,
 407                        arg_real_part);
 408     parent->parent()->insert_before(new tree_instr(copy_str),
 409                                     parent->list_e());
 410
 411     in_rrr *neg_str =
 412             new in_rrr(io_str, type_void, operand(), result_imag_pointer,
 413                        -arg_imag_part);
 414     parent->remove_instr(the_call);
 415     parent->set_instr(neg_str);
 416     delete the_call;
 417   }
 418
 419 static proc_sym *find_math_sym(char *fast_name, char *base_name)
 420   {
 421     proc_sym *fast_sym = fileset->globals()->lookup_proc(fast_name, FALSE);
 422     if (fast_sym != NULL)
 423         return fast_sym;
 424     proc_sym *base_sym = fileset->globals()->lookup_proc(base_name, FALSE);
 425     if (base_sym != NULL)
 426         return base_sym;
 427     func_type *the_type = new func_type(type_double);
 428     the_type = (func_type *)(fileset->globals()->install_type(the_type));
 429     return fileset->globals()->new_proc(the_type, src_unknown, base_name);
 430   }
 431
 432 /*----------------------------------------------------------------------*
 433     End Private Function Implementations
 434  *----------------------------------------------------------------------*/