procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

PR fortran/90903 [part2] - Add runtime checking for the MVBITS intrinsic

Browse source 
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  <pault@gcc.gnu.org>
This commit is contained in:
Harald Anlauf 2020-09-21 21:50:36 +02:00
parent 762c16eba6
commit 5c5ce60990
5 changed files with 247 additions and 24 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
gcc/fortran/iresolve.c
View file

@ -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"),

167
gcc/fortran/trans-intrinsic.c
View file

@ -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;

48
gcc/fortran/trans-stmt.c
View file

@ -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)
{

4
gcc/fortran/trans.h
View file

@ -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;

38
gcc/testsuite/gfortran.dg/check_bits_2.f90 Normal file
View file

@ -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" } }