From a8fbee42e09c65e0965ffce63808a2c11f580739 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 17 Sep 2014 07:28:25 +0200
Subject: [PATCH 3/3] Intern general arrays

* module/system/vm/assembler.scm (intern-constant, link-data): handle
  the array case.
---
 module/system/vm/assembler.scm |   33 ++++++++++++++++++++++++++++++---
 1 file changed, 30 insertions(+), 3 deletions(-)

diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index e944e68..cf8bbdd 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -900,14 +900,15 @@ table, its existing label is used directly."
                          ,(recur (make-uniform-vector-backing-store
                                   (uniform-array->bytevector obj)
                                   width))))))
+     ((array? obj)
+      `((static-patch! ,label 1 ,(recur (shared-array-root obj)))))
      (else
       (error "don't know how to intern" obj))))
   (cond
    ((immediate? obj) #f)
    ((vhash-assoc obj (asm-constants asm)) => cdr)
    (else
-    ;; Note that calling intern may mutate asm-constants and
-    ;; asm-constant-inits.
+    ;; Note that calling intern may mutate asm-constants and asm-inits.
     (let* ((label (gensym "constant"))
            (inits (intern obj label)))
       (set-asm-constants! asm (vhash-cons obj label (asm-constants asm)))
@@ -1218,6 +1219,7 @@ should be .data or .rodata), and return the resulting linker object.
     (+ address
        (modulo (- alignment (modulo address alignment)) alignment)))

+  ;; redefined in libguile/tags.h
   (define tc7-vector 13)
   (define stringbuf-shared-flag #x100)
   (define stringbuf-wide-flag #x400)
@@ -1230,6 +1232,7 @@ should be .data or .rodata), and return the resulting linker object.
   (define tc7-program 69)
   (define tc7-bytevector 77)
   (define tc7-bitvector 95)
+  (define tc7-array 93)

   (let ((word-size (asm-word-size asm))
         (endianness (asm-endianness asm)))
@@ -1254,6 +1257,8 @@ should be .data or .rodata), and return the resulting linker object.
         (* 4 word-size))
        ((uniform-vector-backing-store? x)
         (bytevector-length (uniform-vector-backing-store-bytes x)))
+       ((array? x)
+        (* word-size (+ 3 (* 3 (array-rank x)))))
        (else
         word-size)))

@@ -1310,7 +1315,7 @@ should be .data or .rodata), and return the resulting linker object.
         (write-immediate asm buf pos #f))

        ((string? obj)
-        (let ((tag (logior tc7-ro-string (ash (string-length obj) 8))))
+        (let ((tag (logior tc7-ro-string (ash (string-length obj) 8)))) ; FIXME: unused?
           (case word-size
             ((4)
              (bytevector-u32-set! buf pos tc7-ro-string endianness)
@@ -1385,6 +1390,28 @@ should be .data or .rodata), and return the resulting linker object.
             ;; Need to swap units of element-size bytes
             (error "FIXME: Implement byte order swap"))))

+       ((array? obj)
+        (let ((tag (logior tc7-array (ash (array-rank obj) 17)))
+              (bv-set! (case word-size
+                         ((4) bytevector-u32-set!)
+                         ((8) bytevector-u64-set!)
+                         (else (error "bad word size"))))
+              (bvs-set! (case word-size
+                          ((4) bytevector-s32-set!)
+                          ((8) bytevector-s64-set!)
+                          (else (error "bad word size")))))
+          (bv-set! buf pos tag endianness)
+          (write-immediate asm buf (+ pos word-size) #f) ; root vector (fixed later)
+          (bv-set! buf (+ pos (* word-size 2)) 0 endianness) ; base
+          (let lp ((pos (+ pos (* word-size 3)))
+                   (bounds (array-shape obj))
+                   (incs (shared-array-increments obj)))
+            (when (pair? bounds)
+              (bvs-set! buf pos (first (first bounds)) endianness)
+              (bvs-set! buf (+ pos word-size) (second (first bounds)) endianness)
+              (bvs-set! buf (+ pos (* word-size 2)) (first incs) endianness)
+              (lp (+ pos (* 3 word-size)) (cdr bounds) (cdr incs))))))
+
        (else
         (error "unrecognized object" obj))))

--
1.7.9.5
