Add options for generating contiguous pointer checks

Make sure a pointer target or actual argument is
contiguous when the destination pointer or dummy
argument has the contiguous attribute.

Right now, the checks are enabled through the
following XBITs:

XBIT(54,0x40) - enable the check for pointer
                assignments and actual arguments
                inside callees.

XBIT(54,0x80) - enable the check at call-sites.

XBIT(54,0x100) - use an alternate inline check
                (see xflag.n for more information).

XBIT(54,0x200) - do not flag null pointer targets
                as noncontiguous.

Author: gklimowicz

runtime/flang/rdst.c

@@ -220,6 +220,14 @@ I8(local_copy)(char *db, F90_Desc *dd, __INT_T doffset, char *ab,
   }
 }
 
+/** \brief check if a descriptor is associated with a non-contiguous
+ *         section.
+ *
+ * \param a is the descriptor we are checking.
+ * \param dim is the rank of the array we are checking.
+ *
+ * \returns 0 if contiguous, else the dimension that is non-contiguous.
+ */
 __INT_T
 I8(is_nonsequential_section)(F90_Desc *a, __INT_T dim)
 {
@@ -233,7 +241,7 @@ I8(is_nonsequential_section)(F90_Desc *a, __INT_T dim)
   for (i = 0; i < dim; i++) {
     SET_DIM_PTRS(ad, a, i);
     if (F90_DPTR_LSTRIDE_G(ad) != tmp_lstride || F90_DPTR_SSTRIDE_G(ad) != 1) {
-      is_nonseq_section = 1;
+      is_nonseq_section = i + 1;
       break;
     }
     tmp_lstride *= F90_DPTR_EXTENT_G(ad);
@@ -2744,3 +2752,60 @@ ENTF90(IS_CONTIGUOUS, is_contiguous)(char *ab, F90_Desc *ad)
   return GET_DIST_TRUE_LOG;
 }
 
+/** \brief Print a contiguous error message and abort.
+ *
+ * This function will also call is_nonsequential_section() to get the
+ * first dimension of the array that is non-contiguous and include it in the
+ * error message.
+ *
+ * \param ptr is the pointer we are checking.
+ * \param pd is the descriptor we are checking.
+ * \param lineno is the source line number we are checking. 
+ * \param ptrnam is the name of pointer, null-terminated string.
+ * \param srcfil is the name of source file, null-terminated string.
+ * \param flags is currently 1 when ptr is an optional argument, else 0.
+ */
+void
+ENTF90(CONTIGERROR, contigerror)(void *ptr, F90_Desc *pd, __INT_T lineno,
+                                 char *ptrnam, char *srcfil, __INT_T flags)
+{
+    char str[200];
+    int dim;
+
+    if (flags == 1 && ptr == NULL) {
+      /* ignore non-present optional argument */
+      return;
+    }
+    dim = I8(is_nonsequential_section)(pd, F90_RANK_G(pd));
+    sprintf(str, "Runtime Error at %s, line %d: Pointer assignment of "
+                 "noncontiguous target (dimension %d) to CONTIGUOUS pointer "
+                 "%s\n", srcfil, lineno, dim, ptrnam); 
+    __fort_abort(str);
+}
+
+/** \brief Check whether a pointer is associated with a contiguous array object.
+ *
+ * If the pointer is not associated with a contiguous array object, then a 
+ * message is printed to stderr and the user program aborts.
+ * 
+ * \param ptr is the pointer we are checking.
+ * \param pd is the descriptor we are checking.
+ * \param lineno is the source line number we are checking. 
+ * \param ptrnam is the name of pointer, null-terminated string.
+ * \param srcfil is the name of source file, null-terminated string.
+ * \param flags is currently 1 when ptr is an optional argument, else 0.
+ */
+void
+ENTF90(CONTIGCHK, contigchk)(void *ptr, F90_Desc *pd, __INT_T lineno, 
+                             char *ptrnam, char *srcfil, __INT_T flags)
+{
+  if (flags == 1 && ptr == NULL) {
+    /* ignore non-present optional argument */
+    return;
+  }
+
+  if (!(ENTF90(IS_CONTIGUOUS, is_contiguous)(ptr, pd))) {
+    ENTF90(CONTIGERROR, contigerror)(ptr, pd, lineno, ptrnam, srcfil, flags);
+  }
+}
+  

tools/flang1/flang1exe/dpm_out.c

@@ -2639,6 +2639,22 @@ newargs_for_entry(int this_entry)
         NEWDSCP(arg, newdsc);
       }
     }
+    if (XBIT(54, 0x40) && CONTIGATTRG(arg)
+        && STYPEG(newdsc) != ST_UNKNOWN
+       ) { 
+      /* Generate contiguity check on this argument. 
+       * 
+       * NOTE: For LLVM targets, this function gets called by
+       * newargs_for_llvmiface() to set up placeholder descriptor
+       * arguments in the interface. We do not want to 
+       * generate contiguity checks in this case since an interface
+       * block is non-executable code. The sym_get_arg_sec() function
+       * above returns a newdsc without any STYPE when we're processing
+       * an interface. Therefore, we check whether STYPEG(newdsc) != ST_UNKNOWN.
+       */
+      int ast = mk_id(arg);
+      gen_contig_check(ast, ast, newdsc, FUNCLINEG(gbl.currsub), false, Gbegin);
+    }
     SCP(newdsc, SC_DUMMY);
     OPTARGP(newdsc, OPTARGG(arg));
     NEWARGP(newdsc, 0);

tools/flang1/flang1exe/rest.c

@@ -1356,6 +1356,11 @@ transform_call(int std, int ast)
       inface_arg = aux.dpdsc_base[dscptr + i];
       needdescr = needs_descriptor(inface_arg);
       /* actually, only for pointer or assumed-shape arguments dummy */
+      if (XBIT(54, 0x80) && inface_arg > NOSYM && ast_is_sym(ele) &&
+          needs_descriptor(memsym_of_ast(ele))) {
+        /* Generate contiguity check at call-site */
+        gen_contig_check(mk_id(inface_arg), ele, 0, gbl.lineno, true, std); 
+      }
     }
     if (ele == 0) {
       ARGT_ARG(newargt, newi) = ele;

tools/flang1/flang1exe/rte.c

@@ -827,6 +827,41 @@ get_header_member(int sdsc, int info)
   return ast;
 }
 
+
+/** \brief Generate an AST for accessing a particular field in a descriptor
+ *         header.
+ *
+ * Note: This is similar to get_header_member() above except it also 
+ * operates on descriptors that are embedded in derived type objects.
+ *
+ * \param parent is the ast of the expression with the descriptor that
+ *        we want to access. This is needed if the descriptor is embedded
+ *        in a derived type object.
+ * \param sdsc is the symbol table pointer of the descriptor we want to
+ *        access.
+ * \param info is the field we want to access in the descriptor.
+ *
+ * \return an ast expression of the descriptor access.
+ */
+int
+get_header_member_with_parent(int parent, int sdsc, int info)
+{
+  int ast;
+  int subs[1];
+
+#if DEBUG
+  if (!sdsc)
+    interr("get_header_member, blank static descriptor", 0, 3);
+  else if (STYPEG(sdsc) != ST_ARRDSC && STYPEG(sdsc) != ST_DESCRIPTOR &&
+           DTY(DTYPEG(sdsc)) != TY_ARRAY)
+    interr("get_header_member, bad static descriptor", sdsc, 3);
+#endif
+  subs[0] = mk_isz_cval(info, astb.bnd.dtype);
+  ast = mk_subscr(check_member(parent, mk_id(sdsc)), subs, 1, astb.bnd.dtype);
+  return ast;
+}
+
+
 static int
 get_array_rank(int sdsc)
 {

tools/flang1/flang1exe/semant.h

@@ -1517,6 +1517,7 @@ int do_distbegin(DOINFO *, int, int);
 /* semutil.c */
 void check_derived_type_array_section(int);
 int add_ptr_assign(int, int, int);
+void gen_contig_check(int dest, int src, SPTR sdsc, int lineno, bool cs, int std);
 int collapse_begin(DOINFO *);
 int collapse_add(DOINFO *);
 void link_parents(STSK *, int);