e, a pair uses its car and
;;; cdr, a string uses its stringbuf, etc.
;;;
;;; Some things we want to add to the constant table are not actually
;;; Scheme objects: for example, stringbufs, cache cells for toplevel
;;; references, or cache cells for non-closure procedures.  For these we
;;; define special record types and add instances of those record types
;;; to the table.
;;;

(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 key)
  cache-cell?
  (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 (add-desc! label desc)
    (set-asm-inits! asm (vhash-consq label desc (asm-inits asm))))
  (define (init-descriptor obj)
    (let ((label (recur obj)))
      (cond
       ((not label) #f)
       ((vhash-assq label (asm-inits asm)) => cdr)
       (else
        (let ((desc (vector #f #t '())))
          (add-desc! label desc)
          desc)))))
  (define (add-patch! dst field obj)
    (match (init-descriptor obj)
      (#f #f)
      ((and desc #(emit-init emit-load patches))
       (vector-set! desc 2 (acons dst field patches)))))
  (define (add-init! dst init)
    (add-desc! dst (vector init #f '())))
  (define (intern! obj label)
    (define (patch! field obj) (add-patch! label field obj))
    (define (init! emit-init) (add-init! label emit-init))
    (cond
     ((pair? obj)
      (patch! 0 (car obj))
      (patch! 1 (cdr obj)))
     ((simple-vector? obj)
      (let lp ((i 0))
        (when (< i (vector-length obj))
          (patch! (1+ i) (vector-ref obj i))
          (lp (1+ i)))))
     ((syntax? obj)
      (patch! 1 (syntax-expression obj))
      (patch! 2 (syntax-wrap obj))
      (patch! 3 (syntax-module obj))
      (patch! 4 (syntax-sourcev obj)))
     ((stringbuf? obj))
     ((static-procedure? obj)
      ;; Special case, as we can't load the procedure's code using
      ;; make-non-immediate.
      (let* ((code (static-procedure-code obj))
             (init (lambda (asm label)
                     (emit-static-patch! asm label 1 code)
                     #f)))
        (add-desc! label (vector init #t '()))))
     ((cache-cell? obj))
     ((symbol? obj)
      (unless (symbol-interned? obj)
        (error "uninterned symbol cannot be saved to object file" obj))
      (let ((str-label (recur (symbol->string obj))))
        (init! (lambda (asm label)
                 (emit-make-non-immediate asm 1 str-label)
                 (emit-string->symbol asm 1 1)
                 (emit-static-set! asm 1 label 0)
                 1))))
     ((string? obj)
      (patch! 1 (make-stringbuf obj)))
     ((keyword? obj)
      (let ((sym-label (recur (keyword->symbol obj))))
        (init! (lambda (asm label)
                 (emit-static-ref asm 1 sym-label)
                 (emit-symbol->keyword asm 1 1)
                 (emit-static-set! asm 1 label 0)
                 1))))
     ((number? obj)
      (let ((str-label (recur (number->string obj))))
        (init! (lambda (asm label)
                 (emit-make-non-immediate asm 1 str-label)
                 (emit-string->number asm 1 1)
                 (emit-static-set! asm 1 label 0)
                 1))))
     ((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)))))
        (patch! 2
                (make-uniform-vector-backing-store
                 (uniform-array->bytevector obj)
                 width))))
     ((array? obj)
      (patch! 1 (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
    (let ((label (gensym "constant")))
      ;; Note that calling intern may mutate asm-constants and asm-inits.
      (intern! obj label)
      (set-asm-constants! asm (vhash-cons obj label (asm-constants 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 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 key)))