PR fortran/90903 [part2] - Add runtime checking for the MVBITS intrinsic
authorHarald Anlauf <anlauf@gmx.de>
Mon, 21 Sep 2020 19:50:36 +0000 (21:50 +0200)
committerHarald Anlauf <anlauf@gmx.de>
Mon, 21 Sep 2020 19:50:36 +0000 (21:50 +0200)
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>
gcc/fortran/iresolve.c
gcc/fortran/trans-intrinsic.c
gcc/fortran/trans-stmt.c
gcc/fortran/trans.h
gcc/testsuite/gfortran.dg/check_bits_2.f90 [new file with mode: 0644]

index 73769615c20c1ff93572cb2497f2ae35c5e84271..c2a4865f28f32f146b1db78a2b5de1e1bbac67e2 100644 (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"),
index 32fe9886c5785fac6295bec0f80427c719383dad..3b3bd8629cd39d8260f2e45f2a5beba3f458ba64 100644 (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;
index 1f183b9dcd03ecc042eca67845257577936ec32a..389fec7227e5804a33a186381939920b75d8bbf3 100644 (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)
        {
index d257963d5f89c83ed85c7fe4a7df6f05e6ff4567..16b4215605e8810fa4f88e3ccdfa72415c5d7a74 100644 (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;
diff --git a/gcc/testsuite/gfortran.dg/check_bits_2.f90 b/gcc/testsuite/gfortran.dg/check_bits_2.f90
new file mode 100644 (file)
index 0000000..25357a0
--- /dev/null
@@ -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" } }