static void optimize_assignment (gfc_code *);
static bool optimize_op (gfc_expr *);
static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op);
+static bool optimize_trim (gfc_expr *);
+
+/* How deep we are inside an argument list. */
+
+static int count_arglist;
/* Entry point - run all passes for a namespace. So far, only an
optimization pass is run. */
optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
void *data ATTRIBUTE_UNUSED)
{
- if ((*c)->op == EXEC_ASSIGN)
+
+ gfc_exec_op op;
+
+ op = (*c)->op;
+
+ if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
+ || op == EXEC_CALL_PPC)
+ count_arglist = 1;
+ else
+ count_arglist = 0;
+
+ if (op == EXEC_ASSIGN)
optimize_assignment (*c);
return 0;
}
optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
void *data ATTRIBUTE_UNUSED)
{
+ bool function_expr;
+
+ if ((*e)->expr_type == EXPR_FUNCTION)
+ {
+ count_arglist ++;
+ function_expr = true;
+ }
+ else
+ function_expr = false;
+
+ if (optimize_trim (*e))
+ gfc_simplify_expr (*e, 0);
+
if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
gfc_simplify_expr (*e, 0);
+
+ if (function_expr)
+ count_arglist --;
+
return 0;
}
return false;
}
+/* Optimize a trim function by replacing it with an equivalent substring
+ involving a call to len_trim. This only works for expressions where
+ variables are trimmed. Return true if anything was modified. */
+
+static bool
+optimize_trim (gfc_expr *e)
+{
+ gfc_expr *a;
+ gfc_ref *ref;
+ gfc_expr *fcn;
+ gfc_actual_arglist *actual_arglist, *next;
+
+ /* Don't do this optimization within an argument list, because
+ otherwise aliasing issues may occur. */
+
+ if (count_arglist != 1)
+ return false;
+
+ if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
+ || e->value.function.isym == NULL
+ || e->value.function.isym->id != GFC_ISYM_TRIM)
+ return false;
+
+ a = e->value.function.actual->expr;
+
+ if (a->expr_type != EXPR_VARIABLE)
+ return false;
+
+ if (a->ref)
+ {
+ /* FIXME - also handle substring references, by modifying the
+ reference itself. Make sure not to evaluate functions in
+ the references twice. */
+ return false;
+ }
+ else
+ {
+ strip_function_call (e);
+
+ /* Create the reference. */
+
+ ref = gfc_get_ref ();
+ ref->type = REF_SUBSTRING;
+
+ /* Set the start of the reference. */
+
+ ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+
+ /* Build the function call to len_trim(x, gfc_defaul_integer_kind). */
+
+ fcn = gfc_get_expr ();
+ fcn->expr_type = EXPR_FUNCTION;
+ fcn->value.function.isym =
+ gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
+ actual_arglist = gfc_get_actual_arglist ();
+ actual_arglist->expr = gfc_copy_expr (e);
+ next = gfc_get_actual_arglist ();
+ next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ gfc_default_integer_kind);
+ actual_arglist->next = next;
+ fcn->value.function.actual = actual_arglist;
+
+ /* Set the end of the reference to the call to len_trim. */
+
+ ref->u.ss.end = fcn;
+ e->ref = ref;
+ return true;
+ }
+}
+
#define WALK_SUBEXPR(NODE) \
do \
{ \
int result = codefn (c, &walk_subtrees, data);
if (result)
return result;
+
if (walk_subtrees)
{
gfc_code *b;
+ gfc_actual_arglist *a;
+
switch ((*c)->op)
{
case EXEC_DO:
WALK_SUBEXPR ((*c)->ext.iterator->end);
WALK_SUBEXPR ((*c)->ext.iterator->step);
break;
+
+ case EXEC_CALL:
+ case EXEC_ASSIGN_CALL:
+ for (a = (*c)->ext.actual; a; a = a->next)
+ WALK_SUBEXPR (a->expr);
+ break;
+
+ case EXEC_CALL_PPC:
+ WALK_SUBEXPR ((*c)->expr1);
+ for (a = (*c)->ext.actual; a; a = a->next)
+ WALK_SUBEXPR (a->expr);
+ break;
+
case EXEC_SELECT:
WALK_SUBEXPR ((*c)->expr1);
for (b = (*c)->block; b; b = b->block)
{
gfc_case *cp;
- for (cp = b->ext.case_list; cp; cp = cp->next)
+ for (cp = b->ext.block.case_list; cp; cp = cp->next)
{
WALK_SUBEXPR (cp->low);
WALK_SUBEXPR (cp->high);
WALK_SUBCODE (b->next);
}
continue;
+
case EXEC_ALLOCATE:
case EXEC_DEALLOCATE:
{
WALK_SUBEXPR (a->expr);
break;
}
+
case EXEC_FORALL:
{
gfc_forall_iterator *fa;
}
break;
}
+
case EXEC_OPEN:
WALK_SUBEXPR ((*c)->ext.open->unit);
WALK_SUBEXPR ((*c)->ext.open->file);
WALK_SUBEXPR ((*c)->ext.open->id);
WALK_SUBEXPR ((*c)->ext.open->newunit);
break;
+
case EXEC_CLOSE:
WALK_SUBEXPR ((*c)->ext.close->unit);
WALK_SUBEXPR ((*c)->ext.close->status);
WALK_SUBEXPR ((*c)->ext.close->iostat);
WALK_SUBEXPR ((*c)->ext.close->iomsg);
break;
+
case EXEC_BACKSPACE:
case EXEC_ENDFILE:
case EXEC_REWIND:
WALK_SUBEXPR ((*c)->ext.filepos->iostat);
WALK_SUBEXPR ((*c)->ext.filepos->iomsg);
break;
+
case EXEC_INQUIRE:
WALK_SUBEXPR ((*c)->ext.inquire->unit);
WALK_SUBEXPR ((*c)->ext.inquire->file);
WALK_SUBEXPR ((*c)->ext.inquire->size);
WALK_SUBEXPR ((*c)->ext.inquire->round);
break;
+
case EXEC_WAIT:
WALK_SUBEXPR ((*c)->ext.wait->unit);
WALK_SUBEXPR ((*c)->ext.wait->iostat);
WALK_SUBEXPR ((*c)->ext.wait->iomsg);
WALK_SUBEXPR ((*c)->ext.wait->id);
break;
+
case EXEC_READ:
case EXEC_WRITE:
WALK_SUBEXPR ((*c)->ext.dt->io_unit);
WALK_SUBEXPR ((*c)->ext.dt->sign);
WALK_SUBEXPR ((*c)->ext.dt->extra_comma);
break;
+
case EXEC_OMP_DO:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
default:
break;
}
+
WALK_SUBEXPR ((*c)->expr1);
WALK_SUBEXPR ((*c)->expr2);
WALK_SUBEXPR ((*c)->expr3);
OSDN Git Service
