diate-bits asm #f)))

(define (emit-init-constants asm)
  "If there is writable data that needs initialization at runtime, emit
a procedure to do that and return its label.  Otherwise return
@code{#f}."
  (let ((inits (asm-inits asm)))
    (and (not (null? inits))
         (let ((label (gensym "init-constants")))
           (emit-text asm
                      `((begin-program ,label ())
                        (assert-nargs-ee/locals 1 1)
                        ,@(reverse inits)
                        (load-constant 0 ,*unspecified*)
                        (return-values 2)
                        (end-program)))
           label))))

(define (link-data asm data name)
  "Link the static data for a program into the @var{name} section (which
should be .data or .rodata), and return the resulting linker object.
@var{data} should be a vhash mapping objects to labels."
  (define (align address alignment)
    (+ address
       (modulo (- alignment (modulo address alignment)) alignment)))

  (define tc7-vector #x0d)
  (define vector-immutable-flag #x80)

  (define tc7-string #x15)
  (define string-read-only-flag #x200)

  (define tc7-stringbuf #x27)
  (define stringbuf-wide-flag #x400)

  (define tc7-syntax #x3d)

  (define tc7-program #x45)

  (define tc7-bytevector #x4d)
  ;; This flag is intended to be left-shifted by 7 bits.
  (define bytevector-immutable-flag #x200)

  (define tc7-array #x5d)

  (define tc7-bitvector #x5f)
  (define bitvector-immutable-flag #x80)

  (let ((word-size (asm-word-size asm))
        (endianness (asm-endianness asm)))
    (define (byte-length x)
      (cond
       ((stringbuf? x)
        (let ((x (stringbuf-string x)))
          (+ (* 2 word-size)
             (case (string-bytes-per-char x)
               ((1) (1+ (string-length x)))
               ((4) (* (1+ (string-length x)) 4))
               (else (error "bad string bytes per char" x))))))
       ((static-procedure? x)
        (* 2 word-size))
       ((string? x)
        (* 4 word-size))
       ((pair? x)
        (* 2 word-size))
       ((simple-vector? x)
        (* (1+ (vector-length x)) word-size))
       ((syntax? x)
        (* 4 word-size))
       ((simple-uniform-vector? x)
        (* 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)))

    (define (write-constant-reference buf pos x)
      (let ((bits (immediate-bits asm x)))
        (if bits
            (write-immediate asm buf pos bits)
            ;; The asm-inits will fix up any reference to a
            ;; non-immediate.
            (write-placeholder asm buf pos))))

    (define (write buf pos obj)
      (cond
       ((stringbuf? obj)
        (let* ((x (stringbuf-string obj))
               (len (string-length x))
               (tag (logior tc7-stringbuf
                            (if (= (string-bytes-per-char x) 1)
                                0
                                stringbuf-wide-flag))))
          (case word-size
            ((4)
             (bytevector-u32-set! buf pos tag endianness)
             (bytevector-u32-set! buf (+ pos 4) len endianness))
            ((8)
             (bytevector-u64-set! buf pos tag endianness)
             (bytevector-u64-set! buf (+ pos 8) len endianness))
            (else
             (error "bad word size" asm)))
          (let ((pos (+ pos (* word-size 2))))
            (case (string-bytes-per-char x)
              ((1)
               (let lp ((i 0))
                 (if (< i len)
                     (let ((u8 (char->integer (string-ref x i))))
                       (bytevector-u8-set! buf (+ pos i) u8)
                       (lp (1+ i)))
                     (bytevector-u8-set! buf (+ pos i) 0))))
              ((4)
               (let lp ((i 0))
                 (if (< i len)
                     (let ((u32 (char->integer (string-ref x i))))
                       (bytevector-u32-set! buf (+ pos (* i 4)) u32 endianness)
                       (lp (1+ i)))
                     (bytevector-u32-set! buf (+ pos (* i 4)) 0 endianness))))
              (else (error "bad string bytes per char" x))))))

       ((static-procedure? obj)
        (case word-size
          ((4)
           (bytevector-u32-set! buf pos tc7-program endianness)
           (bytevector-u32-set! buf (+ pos 4) 0 endianness))
          ((8)
           (bytevector-u64-set! buf pos tc7-program endianness)
           (bytevector-u64-set! buf (+ pos 8) 0 endianness))
          (else (error "bad word size"))))

       ((cache-cell? obj)
        (write-placeholder asm buf pos))

       ((string? obj)
        (let ((tag (logior tc7-string string-read-only-flag)))
          (case word-size
            ((4)
             (bytevector-u32-set! buf pos tag endianness)
             (write-placeholder asm buf (+ pos 4)) ; stringbuf
             (bytevector-u32-set! buf (+ pos 8) 0 endianness)
             (bytevector-u32-set! buf (+ pos 12) (string-length obj) endianness))
            ((8)
             (bytevector-u64-set! buf pos tag endianness)
             (write-placeholder asm buf (+ pos 8)) ; stringbuf
             (bytevector-u64-set! buf (+ pos 16) 0 endianness)
             (bytevector-u64-set! buf (+ pos 24) (string-length obj) endianness))
            (else (error "bad word size")))))

       ((pair? obj)
        (write-constant-reference buf pos (car obj))
        (write-constant-reference buf (+ pos word-size) (cdr obj)))

       ((simple-vector? obj)
        (let* ((len (vector-length obj))
               (tag (logior tc7-vector vector-immutable-flag (ash len 8))))
          (case word-size
            ((4) (bytevector-u32-set! buf pos tag endianness))
            ((8) (bytevector-u64-set! buf pos tag endianness))
            (else (error "bad word size")))
          (let lp ((i 0))
            (when (< i (vector-length obj))
              (let ((pos (+ pos word-size (* i word-size)))
                    (elt (vector-ref obj i)))
                (write-constant-reference buf pos elt)
                (lp (1+ i)))))))

       ((symbol? obj)
        (write-placeholder asm buf pos))

       ((keyword? obj)
        (write-placeholder asm buf pos))

       ((syntax? obj)
        (case word-size
          ((4) (bytevector-u32-set! buf pos tc7-syntax endianness))
          ((8) (bytevector-u64-set! buf pos tc7-syntax endianness))
          (else (error "bad word size")))
        (write-constant-reference buf (+ pos (* 1 word-size))
                                  (syntax-expression obj))
        (write-constant-reference buf (+ pos (* 2 word-size))
                                  (syntax-wrap obj))
        (write-constant-reference buf (+ pos (* 3 word-size))
                                  (syntax-module obj)))

       ((number? obj)
        (write-placeholder asm buf pos))

       ((simple-uniform-vector? obj)
        (let ((tag (if (bitvector? obj)
                       (logior tc7-bitvector
                               bitvector-immutable-flag)
                       (logior tc7-bytevector
                               ;; Bytevector immutable flag also shifted
                               ;; left.
                               (ash (logior bytevector-immutable-flag
                                            (array-type-code obj))
                                    7)))))
          (case word-size
            ((4)
             (bytevector-u32-set! buf pos tag endianness)
             (bytevector-u32-set! buf (+ pos 4)
                                  (if (bitvector? obj)
                                      (bitvector-length obj)
                                      (bytevector-length obj))
                                  endianness)                 ; length
             (bytevector-u32-set! buf (+ pos 8) 0 endianness) ; pointer
             (write-placeholder asm buf (+ pos 12)))          ; owner
            ((8)
             (bytevector-u64-set! buf pos tag endianness)
             (bytevector-u64-set! buf (+ pos 8)
                                  (if (bitvector? obj)
                                      (bitvector-length obj)
                                      (bytevector-length obj))
                                  endianness)                  ; length
             (bytevector-u64-set! buf (+ pos 16) 0 endianness) ; pointer
             (write-placeholder asm buf (+ pos 24)))           ; owner
            (else (error "bad word size")))))

       ((uniform-vector-backing-store? obj)
        (let ((bv (uniform-vector-backing-store-bytes obj)))
          (bytevector-copy! bv 0 buf pos (bytevector-length bv))
          (unless (eq? endianness (native-endianness))
            (case (uniform-vector-backing-store-element-size obj)
              ((1) #f) ;; Nothing to do.
              ((2) (byte-swap/2! buf pos (+ pos (bytevector-length bv))))
              ((4) (byte-swap/4! buf pos (+ pos (bytevector-length bv))))
              ((8) (byte-swap/8! buf pos (+ pos (bytevector-length bv))))
              (else (error "FIXME: Implement byte order swap"))))))

       ((array? obj)
        (let-values
            ;; array tag + rank + contp flag: see libguile/arrays.h .
            (((tag) (logior tc7-array (ash (array-rank obj) 17) (ash 1 16)))
             ((bv-set! bvs-set!)
              (case word-size
                ((4) (values bytevector-u32-set! bytevector-s32-set!))
                ((8) (values bytevector-u64-set! bytevector-s64-set!))
                (else (error "bad word size")))))
          (bv-set! buf pos tag endianness)
          (write-placeholder asm buf (+ pos word-size))      ; 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))))

    (cond
     ((vlist-null? data) #f)
     (else
      (let* ((byte-len (vhash-fold (lambda (k v len)
                                     (+ (byte-length k) (align len 8)))
                                   0 data))
             (buf (make-bytevector byte-len 0)))
        (let lp ((i 0) (pos 0) (symbols '()))
          (if (< i (vlist-length data))
              (let* ((pair (vlist-ref data i))
                     (obj (car pair))
                     (obj-label (cdr pair)))
                (write buf pos obj)
                (lp (1+ i)
                    (align (+ (byte-length obj) pos) 8)
                    (cons (make-linker-symbol obj-label pos) symbols)))
              (make-object asm name buf '() symbols
                           #:flags (match name
                                     ('.data (logior SHF_ALLOC SHF_WRITE))
                                     ('.rodata SHF_ALLOC))))))))))

(define (link-constants asm)
  "Link sections to hold constants needed by the program text emitted
using @var{asm}.

Returns three values: an object for the .rodata section, an object for
the .data section, and a label for an initialization procedure.  Any of
these may be @code{#f}."
  (define (shareable? x)
    (cond
     ((stringbuf? x) #t)
     ((pair? x)
      (and (immediate-bits asm (car x)) (immediate-bits asm (cdr x))))
     ((simple-vector? x)
      (let lp ((i 0))
        (or (= i (vector-length x))
            (and (immediate-bits asm (vector-ref x i))
                 (lp (1+ i))))))
     ((uniform-vector-backing-store? x) #t)
     (else #f)))
  (let* ((constants (asm-constants asm))
         (len (vlist-length constants)))
    (let lp ((i 0)
             (ro vlist-null)
             (rw vlist-null))
      (if (= i len)
          (values (link-data asm ro '.rodata)
                  (link-data asm rw '.data)
                  (emit-init-constants asm))
          (let ((pair (vlist-ref constants i)))
            (if (shareable? (car pair))
                (lp (1+ i) (vhash-consq (car pair) (cdr pair) ro) rw)
                (lp (1+ i) ro (vhash-consq (car pair) (cdr pair) rw))))))))