From dc0c4ccb1fdfe20a8f924551eef81d92eed4aaa2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 6 Jan 2023 15:31:15 +0100
Subject: assembler: Separate effectful part of 'link-procprops'.

* module/system/vm/assembler.scm (link-procprops): Define
'write-procprops!' and use it.
---
 module/system/vm/assembler.scm | 40 ++++++++++++++++++++++++++--------------
 1 file changed, 26 insertions(+), 14 deletions(-)

diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 87f9cc2e9..1b0bf5c45 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -2744,20 +2744,32 @@ procedure with label @var{rw-init}.  @var{rw-init} may be false.  If
   (let* ((endianness (asm-endianness asm))
          (procprops (find-procprops))
          (bv (make-bytevector (* (length procprops) procprops-size) 0)))
-    (let lp ((procprops procprops) (pos 0) (relocs '()))
-      (match procprops
-        (()
-         (make-object asm '.guile.procprops
-                      bv
-                      relocs '()
-                      #:type SHT_PROGBITS #:flags 0))
-        (((pc . props) . procprops)
-         (bytevector-u32-set! bv pos pc endianness)
-         (lp procprops
-             (+ pos procprops-size)
-             (cons (make-linker-reloc 'abs32/1 (+ pos 4) 0
-                                      (intern-constant asm props))
-                   relocs)))))))
+    (define (write-procprops! bv offset)
+      (let lp ((procprops procprops) (pos offset))
+        (match procprops
+          (()
+           #t)
+          (((pc . props) . procprops)
+           (bytevector-u32-set! bv pos pc endianness)
+           (lp procprops (+ pos procprops-size))))))
+
+    (define relocs
+      (let lp ((procprops procprops) (pos 0) (relocs '()))
+        (match procprops
+          (()
+           relocs)
+          (((pc . props) . procprops)
+           (lp procprops
+               (+ pos procprops-size)
+               (cons (make-linker-reloc 'abs32/1 (+ pos 4) 0
+                                        (intern-constant asm props))
+                     relocs))))))
+
+    (write-procprops! bv 0)
+    (make-object asm '.guile.procprops
+                 bv
+                 relocs '()
+                 #:type SHT_PROGBITS #:flags 0)))
 
 ;;;
 ;;; The DWARF .debug_info, .debug_abbrev, .debug_str, and .debug_loc
-- 
cgit v1.2.1