From: Harald Anlauf Date: Mon, 21 Sep 2020 19:50:36 +0000 (+0200) Subject: PR fortran/90903 [part2] - Add runtime checking for the MVBITS intrinsic X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=5c5ce6099082b642294091c83461c928bd028ea1;p=gcc.git PR fortran/90903 [part2] - Add runtime checking for the MVBITS intrinsic Implement inline expansion of the intrinsic elemental subroutine MVBITS with optional runtime checks for valid argument range. gcc/fortran/ChangeLog: * iresolve.c (gfc_resolve_mvbits): Remove unneeded conversion of FROMPOS, LEN and TOPOS arguments to fit a C int. * trans-intrinsic.c (gfc_conv_intrinsic_mvbits): Add inline expansion of MVBITS intrinsic elemental subroutine and add code for runtime argument checking. (gfc_conv_intrinsic_subroutine): Recognise MVBITS intrinsic, but defer handling to gfc_trans_call. * trans-stmt.c (replace_ss): (gfc_trans_call): Adjust to handle inline expansion, scalarization of intrinsic subroutine MVBITS in gfc_conv_intrinsic_mvbits. * trans.h (gfc_conv_intrinsic_mvbits): Add prototype for gfc_conv_intrinsic_mvbits. gcc/testsuite/ChangeLog: * gfortran.dg/check_bits_2.f90: New test. Co-authored-by: Paul Thomas --- diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 73769615c20..c2a4865f28f 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -3311,21 +3311,7 @@ gfc_resolve_mvbits (gfc_code *c) { static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN, INTENT_INOUT, INTENT_IN}; - const char *name; - gfc_typespec ts; - gfc_clear_ts (&ts); - - /* FROMPOS, LEN and TOPOS are restricted to small values. As such, - they will be converted so that they fit into a C int. */ - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - if (c->ext.actual->next->expr->ts.kind != gfc_c_int_kind) - gfc_convert_type (c->ext.actual->next->expr, &ts, 2); - if (c->ext.actual->next->next->expr->ts.kind != gfc_c_int_kind) - gfc_convert_type (c->ext.actual->next->next->expr, &ts, 2); - if (c->ext.actual->next->next->next->next->expr->ts.kind != gfc_c_int_kind) - gfc_convert_type (c->ext.actual->next->next->next->next->expr, &ts, 2); /* TO and FROM are guaranteed to have the same kind parameter. */ name = gfc_get_string (PREFIX ("mvbits_i%d"), diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 32fe9886c57..3b3bd8629cd 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -11790,6 +11790,169 @@ conv_intrinsic_event_query (gfc_code *code) return gfc_finish_block (&se.pre); } + +/* This is a peculiar case because of the need to do dependency checking. + It is called via trans-stmt.c(gfc_trans_call), where it is picked out as + a special case and this function called instead of + gfc_conv_procedure_call. */ +void +gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args, + gfc_loopinfo *loop) +{ + gfc_actual_arglist *actual; + gfc_se argse[5]; + gfc_expr *arg[5]; + gfc_ss *lss; + int n; + + tree from, frompos, len, to, topos; + tree lenmask, oldbits, newbits, bitsize; + tree type, utype, above, mask1, mask2; + + if (loop) + lss = loop->ss; + else + lss = gfc_ss_terminator; + + actual = actual_args; + for (n = 0; n < 5; n++, actual = actual->next) + { + arg[n] = actual->expr; + gfc_init_se (&argse[n], NULL); + + if (lss != gfc_ss_terminator) + { + gfc_copy_loopinfo_to_se (&argse[n], loop); + /* Find the ss for the expression if it is there. */ + argse[n].ss = lss; + gfc_mark_ss_chain_used (lss, 1); + } + + gfc_conv_expr (&argse[n], arg[n]); + + if (loop) + lss = argse[n].ss; + } + + from = argse[0].expr; + frompos = argse[1].expr; + len = argse[2].expr; + to = argse[3].expr; + topos = argse[4].expr; + + /* The type of the result (TO). */ + type = TREE_TYPE (to); + bitsize = build_int_cst (integer_type_node, TYPE_PRECISION (type)); + + /* Optionally generate code for runtime argument check. */ + if (gfc_option.rtcheck & GFC_RTCHECK_BITS) + { + tree nbits, below, ccond; + tree fp = fold_convert (long_integer_type_node, frompos); + tree ln = fold_convert (long_integer_type_node, len); + tree tp = fold_convert (long_integer_type_node, topos); + below = fold_build2_loc (input_location, LT_EXPR, + logical_type_node, frompos, + build_int_cst (TREE_TYPE (frompos), 0)); + above = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, frompos, + fold_convert (TREE_TYPE (frompos), bitsize)); + ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, below, above); + gfc_trans_runtime_check (true, false, ccond, &argse[1].pre, + &arg[1]->where, + "FROMPOS argument (%ld) out of range 0:%d " + "in intrinsic MVBITS", fp, bitsize); + below = fold_build2_loc (input_location, LT_EXPR, + logical_type_node, len, + build_int_cst (TREE_TYPE (len), 0)); + above = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, len, + fold_convert (TREE_TYPE (len), bitsize)); + ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, below, above); + gfc_trans_runtime_check (true, false, ccond, &argse[2].pre, + &arg[2]->where, + "LEN argument (%ld) out of range 0:%d " + "in intrinsic MVBITS", ln, bitsize); + below = fold_build2_loc (input_location, LT_EXPR, + logical_type_node, topos, + build_int_cst (TREE_TYPE (topos), 0)); + above = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, topos, + fold_convert (TREE_TYPE (topos), bitsize)); + ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, below, above); + gfc_trans_runtime_check (true, false, ccond, &argse[4].pre, + &arg[4]->where, + "TOPOS argument (%ld) out of range 0:%d " + "in intrinsic MVBITS", tp, bitsize); + + /* The tests above ensure that FROMPOS, LEN and TOPOS fit into short + integers. Additions below cannot overflow. */ + nbits = fold_convert (long_integer_type_node, bitsize); + above = fold_build2_loc (input_location, PLUS_EXPR, + long_integer_type_node, fp, ln); + ccond = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, above, nbits); + gfc_trans_runtime_check (true, false, ccond, &argse[1].pre, + &arg[1]->where, + "FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) " + "in intrinsic MVBITS", fp, ln, bitsize); + above = fold_build2_loc (input_location, PLUS_EXPR, + long_integer_type_node, tp, ln); + ccond = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, above, nbits); + gfc_trans_runtime_check (true, false, ccond, &argse[4].pre, + &arg[4]->where, + "TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) " + "in intrinsic MVBITS", tp, ln, bitsize); + } + + for (n = 0; n < 5; n++) + { + gfc_add_block_to_block (&se->pre, &argse[n].pre); + gfc_add_block_to_block (&se->post, &argse[n].post); + } + + /* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */ + above = fold_build2_loc (input_location, GE_EXPR, logical_type_node, + len, fold_convert (TREE_TYPE (len), bitsize)); + mask1 = build_int_cst (type, -1); + mask2 = fold_build2_loc (input_location, LSHIFT_EXPR, type, + build_int_cst (type, 1), len); + mask2 = fold_build2_loc (input_location, MINUS_EXPR, type, + mask2, build_int_cst (type, 1)); + lenmask = fold_build3_loc (input_location, COND_EXPR, type, + above, mask1, mask2); + + /* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS. + * For valid frompos+len <= bit_size(FROM) the conversion to unsigned is + * not strictly necessary; artificial bits from rshift will be masked. */ + utype = unsigned_type_for (type); + newbits = fold_build2_loc (input_location, RSHIFT_EXPR, utype, + fold_convert (utype, from), frompos); + newbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, + fold_convert (type, newbits), lenmask); + newbits = fold_build2_loc (input_location, LSHIFT_EXPR, type, + newbits, topos); + + /* oldbits = TO & (~(lenmask << TOPOS)). */ + oldbits = fold_build2_loc (input_location, LSHIFT_EXPR, type, + lenmask, topos); + oldbits = fold_build1_loc (input_location, BIT_NOT_EXPR, type, oldbits); + oldbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, oldbits, to); + + /* TO = newbits | oldbits. */ + se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type, + oldbits, newbits); + + /* Return the assignment. */ + se->expr = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, to, se->expr); +} + + static tree conv_intrinsic_move_alloc (gfc_code *code) { @@ -12119,6 +12282,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code) res = conv_intrinsic_kill_sub (code); break; + case GFC_ISYM_MVBITS: + res = NULL_TREE; + break; + case GFC_ISYM_SYSTEM_CLOCK: res = conv_intrinsic_system_clock (code); break; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 1f183b9dcd0..389fec7227e 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -198,6 +198,13 @@ replace_ss (gfc_se *se, gfc_ss *old_ss, gfc_ss *new_ss) *sess = new_ss; new_ss->next = old_ss->next; + /* Make sure that trailing references are not lost. */ + if (old_ss->info + && old_ss->info->data.array.ref + && old_ss->info->data.array.ref->next + && !(new_ss->info->data.array.ref + && new_ss->info->data.array.ref->next)) + new_ss->info->data.array.ref = old_ss->info->data.array.ref; for (loopss = &(se->loop->ss); *loopss != gfc_ss_terminator; loopss = &((*loopss)->loop_chain)) @@ -383,6 +390,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check, tree index = NULL_TREE; tree maskexpr = NULL_TREE; tree tmp; + bool is_intrinsic_mvbits; /* A CALL starts a new block because the actual arguments may have to be evaluated first. */ @@ -397,17 +405,29 @@ gfc_trans_call (gfc_code * code, bool dependency_check, get_proc_ifc_for_call (code), GFC_SS_REFERENCE); + /* MVBITS is inlined but needs the dependency checking found here. */ + is_intrinsic_mvbits = code->resolved_isym + && code->resolved_isym->id == GFC_ISYM_MVBITS; + /* Is not an elemental subroutine call with array valued arguments. */ if (ss == gfc_ss_terminator) { - /* Translate the call. */ - has_alternate_specifier - = gfc_conv_procedure_call (&se, code->resolved_sym, code->ext.actual, - code->expr1, NULL); + if (is_intrinsic_mvbits) + { + has_alternate_specifier = 0; + gfc_conv_intrinsic_mvbits (&se, code->ext.actual, NULL); + } + else + { + /* Translate the call. */ + has_alternate_specifier = + gfc_conv_procedure_call (&se, code->resolved_sym, + code->ext.actual, code->expr1, NULL); - /* A subroutine without side-effect, by definition, does nothing! */ - TREE_SIDE_EFFECTS (se.expr) = 1; + /* A subroutine without side-effect, by definition, does nothing! */ + TREE_SIDE_EFFECTS (se.expr) = 1; + } /* Chain the pieces together and return the block. */ if (has_alternate_specifier) @@ -490,10 +510,18 @@ gfc_trans_call (gfc_code * code, bool dependency_check, TREE_TYPE (maskexpr), maskexpr); } - /* Add the subroutine call to the block. */ - gfc_conv_procedure_call (&loopse, code->resolved_sym, - code->ext.actual, code->expr1, - NULL); + if (is_intrinsic_mvbits) + { + has_alternate_specifier = 0; + gfc_conv_intrinsic_mvbits (&loopse, code->ext.actual, &loop); + } + else + { + /* Add the subroutine call to the block. */ + gfc_conv_procedure_call (&loopse, code->resolved_sym, + code->ext.actual, code->expr1, + NULL); + } if (mask && count1) { diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index d257963d5f8..16b4215605e 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -818,6 +818,10 @@ bool gfc_omp_private_outer_ref (tree); struct gimplify_omp_ctx; void gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *, tree); +/* In trans-intrinsic.c. */ +void gfc_conv_intrinsic_mvbits (gfc_se *, gfc_actual_arglist *, + gfc_loopinfo *); + /* Runtime library function decls. */ extern GTY(()) tree gfor_fndecl_pause_numeric; extern GTY(()) tree gfor_fndecl_pause_string; diff --git a/gcc/testsuite/gfortran.dg/check_bits_2.f90 b/gcc/testsuite/gfortran.dg/check_bits_2.f90 new file mode 100644 index 00000000000..25357a0dde1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/check_bits_2.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-options "-fcheck=bits -fdump-tree-original" } +! { dg-shouldfail "Fortran runtime error: FROMPOS(64)+LEN(1)>BIT_SIZE(64) in intrinsic MVBITS" } +! { dg-output "At line 33 .*" } +! +! Verify that the runtime checks for the MVBITS intrinsic functions +! do not generate false-positives +program check + implicit none + integer, parameter :: bs4 = bit_size (1_4) + integer, parameter :: bs8 = bit_size (1_8) + integer(4), dimension(0:bs4) :: from4, frompos4, len4, to4, topos4 + integer(8), dimension(0:bs8) :: from8, frompos8, len8, to8, topos8 + integer :: i + from4 = -1 + to4 = -1 + len4 = [ (i, i=0,bs4) ] + frompos4 = bs4 - len4 + topos4 = frompos4 + call mvbits (from4, frompos4, len4, to4, topos4) + if (any (to4 /= -1)) stop 1 + from8 = -1 + to8 = -1 + len8 = [ (i, i=0,bs8) ] + frompos8 = bs8 - len8 + topos8 = frompos8 + call mvbits (from8, frompos8, len8, to8, topos8) + if (any (to8 /= -1)) stop 2 + from8 = -1 + to8 = -1 + len8(0) = 1 + ! The following line should fail with a runtime error: + call mvbits (from8, frompos8, len8, to8, topos8) + ! Should never get here with -fcheck=bits + stop 3 +end + +! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" 15 "original" } }