Give single-statement while/repeat bodies their own hoist target

while and repeat forwarded the enclosing statement's hoist into the loop
body. A `{` body is unaffected (each statement gets its own hoist), but
a single-statement body's hoisted code -- BLAS calls, temporaries,
runtime guards -- was emitted once, before the loop:

    while (m[1, 1] < 8) m <- m %*% m

compiled the dgemm call ahead of `do while` with `m = btmp1_` as the
loop body, an infinite loop (or stale result) where R terminates. Both
bodies now compile with their own per-statement hoist, exactly as `{`
bodies, the `if` handler's branches and (since #141) the `for` handler
already do. Pre-existing bug (predates this branch), surfaced by review
(fable-final-review.md #1); the condition-side fix in the previous
commit made the pattern obvious.

Author: mns-nordicals

R/r2f-control-flow.R

@@ -38,9 +38,13 @@ r2f_handlers[["if"]] <- function(args, scope, ..., hoist = NULL) {
 # TODO: return
 
 # ---- repeat ----
-r2f_handlers[["repeat"]] <- function(args, scope, ...) {
+r2f_handlers[["repeat"]] <- function(args, scope, ..., hoist = NULL) {
   stopifnot(length(args) == 1L)
-  body <- r2f(args[[1]], scope, ...)
+  # The body gets its own hoist target: forwarding the enclosing
+  # statement's hoist would emit a single-statement body's hoisted code
+  # (BLAS calls, temporaries, guards) once, before the loop, instead of
+  # per iteration. (`{` bodies already isolate each statement.)
+  body <- r2f(args[[1]], scope, ..., hoist = NULL)
   check_pending_parallel_consumed(scope)
   Fortran(glue(
     "do
@@ -72,7 +76,11 @@ r2f_handlers[["while"]] <- function(args, scope, ..., hoist = NULL) {
   # present, lower to an explicit exit check at the top of the loop body.
   cond_hoist <- new_hoist(scope)
   cond <- r2f(args[[1]], scope, ..., hoist = cond_hoist)
-  body <- r2f(args[[2]], scope, ..., hoist = hoist)
+  # The body gets its own hoist target for the same reason: forwarding the
+  # enclosing statement's hoist would emit a single-statement body's
+  # hoisted code (BLAS calls, temporaries, guards) once, before the loop.
+  # (`{` bodies already isolate each statement.)
+  body <- r2f(args[[2]], scope, ..., hoist = NULL)
   check_pending_parallel_consumed(scope)
   exit_check <- glue("if (.not. ({cond})) exit")
   cond_code <- cond_hoist$render(exit_check)

tests/testthat/_snaps/loops.md

@@ -461,3 +461,153 @@
         return out_;
       }
 
+# single-statement while/repeat bodies re-run their hoisted statements
+
+    Code
+      fn
+    Output
+      function(m) {
+          declare(type(m = double(2, 2)))
+          while (m[1, 1] < 100) m <- m %*% m
+          m
+        }
+      <environment: 0x0>
+    Code
+      cat(fsub)
+    Output
+      subroutine fn(m) bind(c)
+        use iso_c_binding, only: c_double, c_int
+        implicit none
+      
+        ! manifest start
+        ! args
+        real(c_double), intent(in out) :: m(2, 2)
+        ! manifest end
+      
+      
+        do while ((m(1_c_int, 1_c_int) < 100.0_c_double))
+          block
+            real(c_double) :: btmp1_(2, 2)
+      
+      call dgemm('N','N', int(2, kind=c_int), int(2, kind=c_int), int(2, kind=c_int), 1.0_c_double, m, int(2, kind=c_int), m, int(2,&
+      & kind=c_int), 0.0_c_double, btmp1_, int(2, kind=c_int))
+            m = btmp1_
+          end block
+        end do
+      end subroutine
+    Code
+      cat(cwrapper)
+    Output
+      #define R_NO_REMAP
+      #include <R.h>
+      #include <Rinternals.h>
+      
+      
+      extern void fn(double* const m__);
+      
+      SEXP fn_(SEXP _args) {
+        // m
+        _args = CDR(_args);
+        SEXP m = CAR(_args);
+        if (TYPEOF(m) != REALSXP) {
+          Rf_error("typeof(m) must be 'double', not '%s'", Rf_type2char(TYPEOF(m)));
+        }
+        m = Rf_duplicate(m);
+        SETCAR(_args, m);
+        double* const m__ = REAL(m);
+        const int* const m__dim_ = ({
+        SEXP dim_ = Rf_getAttrib(m, R_DimSymbol);
+        if (Rf_length(dim_) != 2) Rf_error(
+          "m must be a 2D-array, but length(dim(m)) is %i",
+          (int) Rf_length(dim_));
+        INTEGER(dim_);});
+        const int m__dim_1_ = m__dim_[0];
+        const int m__dim_2_ = m__dim_[1];
+        
+        if (m__dim_1_ != 2)
+          Rf_error("dim(m)[1] must be 2, not %0.f",
+                    (double)m__dim_1_);
+        if (m__dim_2_ != 2)
+          Rf_error("dim(m)[2] must be 2, not %0.f",
+                    (double)m__dim_2_);
+        
+        fn(m__);
+        
+        return m;
+      }
+
+---
+
+    Code
+      fn
+    Output
+      function(m) {
+          declare(type(m = double(2, 2)))
+          repeat m <- m %*% m
+          m
+        }
+      <environment: 0x0>
+    Code
+      cat(fsub)
+    Output
+      subroutine fn(m) bind(c)
+        use iso_c_binding, only: c_double, c_int
+        implicit none
+      
+        ! manifest start
+        ! args
+        real(c_double), intent(in out) :: m(2, 2)
+        ! manifest end
+      
+      
+        do
+          block
+            real(c_double) :: btmp1_(2, 2)
+      
+      call dgemm('N','N', int(2, kind=c_int), int(2, kind=c_int), int(2, kind=c_int), 1.0_c_double, m, int(2, kind=c_int), m, int(2,&
+      & kind=c_int), 0.0_c_double, btmp1_, int(2, kind=c_int))
+            m = btmp1_
+          end block
+        end do
+      end subroutine
+    Code
+      cat(cwrapper)
+    Output
+      #define R_NO_REMAP
+      #include <R.h>
+      #include <Rinternals.h>
+      
+      
+      extern void fn(double* const m__);
+      
+      SEXP fn_(SEXP _args) {
+        // m
+        _args = CDR(_args);
+        SEXP m = CAR(_args);
+        if (TYPEOF(m) != REALSXP) {
+          Rf_error("typeof(m) must be 'double', not '%s'", Rf_type2char(TYPEOF(m)));
+        }
+        m = Rf_duplicate(m);
+        SETCAR(_args, m);
+        double* const m__ = REAL(m);
+        const int* const m__dim_ = ({
+        SEXP dim_ = Rf_getAttrib(m, R_DimSymbol);
+        if (Rf_length(dim_) != 2) Rf_error(
+          "m must be a 2D-array, but length(dim(m)) is %i",
+          (int) Rf_length(dim_));
+        INTEGER(dim_);});
+        const int m__dim_1_ = m__dim_[0];
+        const int m__dim_2_ = m__dim_[1];
+        
+        if (m__dim_1_ != 2)
+          Rf_error("dim(m)[1] must be 2, not %0.f",
+                    (double)m__dim_1_);
+        if (m__dim_2_ != 2)
+          Rf_error("dim(m)[2] must be 2, not %0.f",
+                    (double)m__dim_2_);
+        
+        fn(m__);
+        
+        return m;
+      }
+

tests/testthat/test-loops.R

@@ -103,3 +103,28 @@ test_that("expr return value", {
   expect_translation_snapshots(fn)
   expect_quick_identical(fn, 1:10)
 })
+
+test_that("single-statement while/repeat bodies re-run their hoisted statements", {
+  # A non-`{` loop body whose lone statement hoists code (here a BLAS
+  # call) must emit that code inside the loop; hoisting it out of the
+  # loop would freeze the body's work at its first evaluation. `for` is
+  # covered in test-for-iterables.R.
+  #
+  # Run-tested only via the snapshots: a regression in either would
+  # compute the product once before the loop and never terminate.
+  squarings_while <- function(m) {
+    declare(type(m = double(2, 2)))
+    while (m[1, 1] < 100) m <- m %*% m
+    m
+  }
+
+  expect_translation_snapshots(squarings_while)
+
+  squarings_repeat <- function(m) {
+    declare(type(m = double(2, 2)))
+    repeat m <- m %*% m
+    m
+  }
+
+  expect_translation_snapshots(squarings_repeat)
+})