[flang-commits] [flang] [flang][runtime] Let FORT_CHECK_POINTER_DEALLOCATE=0 disable runtime … (PR #84956)

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/84956

…check

Add an environment variable by which a user can disable the pointer validation check in DEALLOCATE statement handling.  This is not safe, but it can help make a code work that allocates a pointer with an extended derived type, associates its target with a pointer to one of its ancestor types, and then deallocates that pointer.

>From 49324783138814e40ddba52fac1da0ffd3e30b24 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Tue, 12 Mar 2024 10:27:25 -0700
Subject: [PATCH] [flang][runtime] Let FORT_CHECK_POINTER_DEALLOCATE=0 disable
 runtime check

Add an environment variable by which a user can disable the pointer
validation check in DEALLOCATE statement handling.  This is not
safe, but it can help make a code work that allocates a pointer
with an extended derived type, associates its target with a pointer
to one of its ancestor types, and then deallocates that pointer.
---
 flang/docs/RuntimeEnvironment.md | 57 ++++++++++++++++++++++++++++++++
 flang/runtime/environment.cpp    | 13 ++++++++
 flang/runtime/environment.h      |  1 +
 flang/runtime/pointer.cpp        | 26 +++++++++------
 4 files changed, 86 insertions(+), 11 deletions(-)
 create mode 100644 flang/docs/RuntimeEnvironment.md

diff --git a/flang/docs/RuntimeEnvironment.md b/flang/docs/RuntimeEnvironment.md
new file mode 100644
index 00000000000000..083e379072e807
--- /dev/null
+++ b/flang/docs/RuntimeEnvironment.md
@@ -0,0 +1,57 @@
+<!--===- docs/RuntimeTypeInfo.md 
+  
+   Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+   See https://llvm.org/LICENSE.txt for license information.
+   SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+  
+-->
+
+```{contents}
+---
+local:
+---
+```
+
+# Environment variables of significance to Fortran execution
+
+A few environment variables are queried by the Fortran runtime support
+library.
+
+The following environment variables can affect the behavior of
+Fortran programs during execution.
+
+## `DEFAULT_UTF8=1`
+
+Set `DEFAULT_UTF8` to cause formatted external input to assume UTF-8
+encoding on input and use UTF-8 encoding on formatted external output.
+
+## `FORT_CONVERT`
+
+Determines data conversions applied to unformatted I/O.
+
+* `NATIVE`: no conversions (default)
+* `LITTLE_ENDIAN`: assume input is little-endian; emit little-endian output
+* `BIG_ENDIAN`: assume input is big-endian; emit big-endian output
+* `SWAP`: reverse endianness (always convert)
+
+## `FORT_CHECK_POINTER_DEALLOCATION`
+
+Fortran requires that a pointer that appears in a `DEALLOCATE` statement
+must have been allocated in an `ALLOCATE` statement with the same declared
+type.
+The runtime support library validates this requirement by checking the
+size of the allocated data, and will fail with an error message if
+the deallocated pointer is not valid.
+Set `FORT_CHECK_POINTER_DEALLOCATION=0` to disable this check.
+
+## `FORT_FMT_RECL`
+
+Set to an integer value to specify the record length for list-directed
+and `NAMELIST` output.
+The default is 72.
+
+## `NO_STOP_MESSAGE`
+
+Set `NO_STOP_MESSAGE=1` to disable the extra information about
+IEEE floating-point exception flags that the Fortran language
+standard requires for `STOP` and `ERROR STOP` statements.
diff --git a/flang/runtime/environment.cpp b/flang/runtime/environment.cpp
index 62d9ee2afd1ceb..29196ae8f31051 100644
--- a/flang/runtime/environment.cpp
+++ b/flang/runtime/environment.cpp
@@ -123,6 +123,19 @@ void ExecutionEnvironment::Configure(int ac, const char *av[],
     }
   }
 
+  if (auto *x{std::getenv("FORT_CHECK_POINTER_DEALLOCATION")}) {
+    char *end;
+    auto n{std::strtol(x, &end, 10)};
+    if (n >= 0 && n <= 1 && *end == '\0') {
+      checkPointerDeallocation = n != 0;
+    } else {
+      std::fprintf(stderr,
+          "Fortran runtime: FORT_CHECK_POINTER_DEALLOCATION=%s is invalid; "
+          "ignored\n",
+          x);
+    }
+  }
+
   // TODO: Set RP/ROUND='PROCESSOR_DEFINED' from environment
 }
 
diff --git a/flang/runtime/environment.h b/flang/runtime/environment.h
index 82a5ec8f4ebfb0..6da2c7bb3cf78a 100644
--- a/flang/runtime/environment.h
+++ b/flang/runtime/environment.h
@@ -48,6 +48,7 @@ struct ExecutionEnvironment {
   Convert conversion{Convert::Unknown}; // FORT_CONVERT
   bool noStopMessage{false}; // NO_STOP_MESSAGE=1 inhibits "Fortran STOP"
   bool defaultUTF8{false}; // DEFAULT_UTF8
+  bool checkPointerDeallocation{true}; // FORT_CHECK_POINTER_DEALLOCATION
 };
 
 extern ExecutionEnvironment executionEnvironment;
diff --git a/flang/runtime/pointer.cpp b/flang/runtime/pointer.cpp
index fc9e0eeb7dac99..08a1223764f393 100644
--- a/flang/runtime/pointer.cpp
+++ b/flang/runtime/pointer.cpp
@@ -9,6 +9,7 @@
 #include "flang/Runtime/pointer.h"
 #include "assign-impl.h"
 #include "derived.h"
+#include "environment.h"
 #include "stat.h"
 #include "terminator.h"
 #include "tools.h"
@@ -184,17 +185,20 @@ int RTDEF(PointerDeallocate)(Descriptor &pointer, bool hasStat,
   if (!pointer.IsAllocated()) {
     return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
   }
-  // Validate the footer.  This should fail if the pointer doesn't
-  // span the entire object, or the object was not allocated as a
-  // pointer.
-  std::size_t byteSize{pointer.Elements() * pointer.ElementBytes()};
-  constexpr std::size_t align{sizeof(std::uintptr_t)};
-  byteSize = ((byteSize + align - 1) / align) * align;
-  void *p{pointer.raw().base_addr};
-  std::uintptr_t *footer{
-      reinterpret_cast<std::uintptr_t *>(static_cast<char *>(p) + byteSize)};
-  if (*footer != ~reinterpret_cast<std::uintptr_t>(p)) {
-    return ReturnError(terminator, StatBadPointerDeallocation, errMsg, hasStat);
+  if (executionEnvironment.checkPointerDeallocation) {
+    // Validate the footer.  This should fail if the pointer doesn't
+    // span the entire object, or the object was not allocated as a
+    // pointer.
+    std::size_t byteSize{pointer.Elements() * pointer.ElementBytes()};
+    constexpr std::size_t align{sizeof(std::uintptr_t)};
+    byteSize = ((byteSize + align - 1) / align) * align;
+    void *p{pointer.raw().base_addr};
+    std::uintptr_t *footer{
+        reinterpret_cast<std::uintptr_t *>(static_cast<char *>(p) + byteSize)};
+    if (*footer != ~reinterpret_cast<std::uintptr_t>(p)) {
+      return ReturnError(
+          terminator, StatBadPointerDeallocation, errMsg, hasStat);
+    }
   }
   return ReturnError(terminator,
       pointer.Destroy(/*finalize=*/true, /*destroyPointers=*/true, &terminator),