instances of those record types
;;; to the table.
;;;

(define (immediate-bits asm x)
  "Return the bit pattern to write into the buffer if @var{x} is
immediate, and @code{#f} otherwise."
  (define tc2-int 2)
  (if (exact-integer? x)
      ;; Object is an immediate if it is a fixnum on the target.
      (call-with-values (lambda ()
                          (case (asm-word-size asm)
                            ((4) (values    (- #x20000000)
                                            #x1fffffff))
                            ((8) (values    (- #x2000000000000000)
                                            #x1fffffffFFFFFFFF))
                            (else (error "unexpected word size"))))
        (lambda (fixnum-min fixnum-max)
          (and (<= fixnum-min x fixnum-max)
               (let ((fixnum-bits (if (negative? x)
                                      (+ fixnum-max 1 (logand x fixnum-max))
                                      x)))
                 (logior (ash fixnum-bits 2) tc2-int)))))
      ;; Otherwise, the object will be immediate on the target if and
      ;; only if it is immediate on the host.  Except for integers,
      ;; which we handle specially above, any immediate value is an
      ;; immediate on both 32-bit and 64-bit targets.
      (let ((bits (object-address x)))
        (and (not (zero? (logand bits 6)))
             bits))))

(define-record-type <stringbuf>
  (make-stringbuf string)
  stringbuf?
  (string stringbuf-string))

(define-record-type <static-procedure>
  (make-static-procedure code)
  static-procedure?
  (code static-procedure-code))

(define-record-type <uniform-vector-backing-store>
  (make-uniform-vector-backing-store bytes element-size)
  uniform-vector-backing-store?
  (bytes uniform-vector-backing-store-bytes)
  (element-size uniform-vector-backing-store-element-size))

(define-record-type <cache-cell>
  (make-cache-cell scope key)
  cache-cell?
  (scope cache-cell-scope)
  (key cache-cell-key))

(define (simple-vector? obj)
  (and (vector? obj)
       (equal? (array-shape obj) (list (list 0 (1- (vector-length obj)))))))

(define (simple-uniform-vector? obj)
  (and (array? obj)
       (symbol? (array-type obj))
       (match (array-shape obj)
         (((0 n)) #t)
         (else #f))))

(define (statically-allocatable? x)
  "Return @code{#t} if a non-immediate constant can be allocated
statically, and @code{#f} if it would need some kind of runtime
allocation."
  (or (pair? x) (string? x) (stringbuf? x) (static-procedure? x)
      (array? x) (syntax? x)))

(define (intern-constant asm obj)
  "Add an object to the constant table, and return a label that can be
used to reference it.  If the object is already present in the constant
table, its existing label is used directly."
  (define (recur obj)
    (intern-constant asm obj))
  (define (field dst n obj)
    (let ((src (recur obj)))
      (if src
          (if (statically-allocatable? obj)
              `((static-patch! ,dst ,n ,src))
              `((static-ref 1 ,src)
                (static-set! 1 ,dst ,n)))
          '())))
  (define (intern obj label)
    (cond
     ((pair? obj)
      (append (field label 0 (car obj))
              (field label 1 (cdr obj))))
     ((simple-vector? obj)
      (let lp ((i 0) (inits '()))
        (if (< i (vector-length obj))
            (lp (1+ i)
                (append-reverse (field label (1+ i) (vector-ref obj i))
                                inits))
            (reverse inits))))
     ((syntax? obj)
      (append (field label 1 (syntax-expression obj))
              (field label 2 (syntax-wrap obj))
              (field label 3 (syntax-module obj))))
     ((stringbuf? obj) '())
     ((static-procedure? obj)
      `((static-patch! ,label 1 ,(static-procedure-code obj))))
     ((cache-cell? obj) '())
     ((symbol? obj)
      (unless (symbol-interned? obj)
        (error "uninterned symbol cannot be saved to object file" obj))
      `((make-non-immediate 1 ,(recur (symbol->string obj)))
        (string->symbol 1 1)
        (static-set! 1 ,label 0)))
     ((string? obj)
      `((static-patch! ,label 1 ,(recur (make-stringbuf obj)))))
     ((keyword? obj)
      `((static-ref 1 ,(recur (keyword->symbol obj)))
        (symbol->keyword 1 1)
        (static-set! 1 ,label 0)))
     ((number? obj)
      `((make-non-immediate 1 ,(recur (number->string obj)))
        (string->number 1 1)
        (static-set! 1 ,label 0)))
     ((uniform-vector-backing-store? obj) '())
     ((simple-uniform-vector? obj)
      (let ((width (case (array-type obj)
                     ((vu8 u8 s8) 1)
                     ((u16 s16) 2)
                     ;; Bitvectors are addressed in 32-bit units.
                     ;; Although a complex number is 8 or 16 bytes wide,
                     ;; it should be byteswapped in 4 or 8 byte units.
                     ((u32 s32 f32 c32 b) 4)
                     ((u64 s64 f64 c64) 8)
                     (else
                      (error "unhandled array type" obj)))))
        `((static-patch! ,label 2
                         ,(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-bits asm obj) #f)
   ((vhash-assoc obj (asm-constants asm)) => cdr)
   (else
    ;; 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)))
      (set-asm-inits! asm (append-reverse inits (asm-inits asm)))
      label))))

(define (intern-non-immediate asm obj)
  "Intern a non-immediate into the constant table, and return its
label."
  (when (immediate-bits asm obj)
    (error "expected a non-immediate" obj))
  (intern-constant asm obj))

(define (intern-cache-cell asm scope key)
  "Intern a cache cell into the constant table, and return its label.
If there is already a cache cell with the given scope and key, it is
returned instead."
  (intern-constant asm (make-cache-cell scope key)))

;; Return the label of the cell that holds the module for a scope.
(define (intern-module-cache-cell asm scope)
  "Intern a cache cell for a module, and return its label."
  (intern-cache-cell asm scope #t))


