mic segment,
;;; the symbol table, etc.
;;;

;; FIXME: Define these somewhere central, shared with C.
(define *bytecode-major-version* #x0300)
(define *bytecode-minor-version* 7)

(define (link-dynamic-section asm text rw rw-init frame-maps)
  "Link the dynamic section for an ELF image with bytecode @var{text},
given the writable data section @var{rw} needing fixup from the
procedure with label @var{rw-init}.  @var{rw-init} may be false.  If
@var{rw} is true, it will be added to the GC roots at runtime."
  (define-syntax-rule (emit-dynamic-section word-size %set-uword! reloc-type)
    (let* ((endianness (asm-endianness asm))
           (words 6)
           (words (if rw (+ words 4) words))
           (words (if rw-init (+ words 2) words))
           (words (if frame-maps (+ words 2) words))
           (size  (* word-size words)))

      (define relocs
        ;; This must match the 'set-label!' calls below.
        (let ((reloc (lambda (i label)
                       (make-linker-reloc 'reloc-type
                                          (* i word-size) 0 label))))
          `(,(reloc 3 '.rtl-text)
            ,@(if rw
                  (list (reloc 5 '.data))
                  '())
            ,@(if (and rw rw-init)
                  (list (reloc 9 rw-init))
                  '())
            ,@(if frame-maps
                  (list (reloc (- words 3) '.guile.frame-maps))
                  '()))))

      (define (write! bv)
        (define (set-uword! i uword)
          (%set-uword! bv (* i word-size) uword endianness))
        (define (set-label! i label)
          (%set-uword! bv (* i word-size) 0 endianness))

        (set-uword! 0 DT_GUILE_VM_VERSION)
        (set-uword! 1 (logior (ash *bytecode-major-version* 16)
                              *bytecode-minor-version*))
        (set-uword! 2 DT_GUILE_ENTRY)
        (set-label! 3 '.rtl-text)
        (when rw
          ;; Add roots to GC.
          (set-uword! 4 DT_GUILE_GC_ROOT)
          (set-label! 5 '.data)
          (set-uword! 6 DT_GUILE_GC_ROOT_SZ)
          (set-uword! 7 (linker-object-size rw))
          (when rw-init
            (set-uword! 8 DT_INIT)                ; constants
            (set-label! 9 rw-init)))
        (when frame-maps
          (set-uword! (- words 4) DT_GUILE_FRAME_MAPS)
          (set-label! (- words 3) '.guile.frame-maps))
        (set-uword! (- words 2) DT_NULL)
        (set-uword! (- words 1) 0))

      (make-object asm '.dynamic size write!
                   relocs '()
                   #:type SHT_DYNAMIC #:flags SHF_ALLOC)))
  (case (asm-word-size asm)
    ((4) (emit-dynamic-section 4 bytevector-u32-set! abs32/1))
    ((8) (emit-dynamic-section 8 bytevector-u64-set! abs64/1))
    (else (error "bad word size" asm))))

(define (link-shstrtab asm)
  "Link the string table for the section headers."
  (intern-section-name! asm ".shstrtab")
  (make-object asm '.shstrtab
               (string-table-size (asm-shstrtab asm))
               (string-table-writer (asm-shstrtab asm))
               '() '()
               #:type SHT_STRTAB #:flags 0))

(define (link-symtab text-section asm)
  (let* ((endianness (asm-endianness asm))
         (word-size (asm-word-size asm))
         (size (elf-symbol-len word-size))
         (meta (reverse (asm-meta asm)))
         (n (length meta))
         (strtab (make-string-table)))
    (define (intern-string! name)
      (string-table-intern! strtab (if name (symbol->string name) "")))
    (define names
      (map (lambda (meta n)
             (intern-string! (meta-name meta)))
           meta (iota n)))
    (define (write-symbols! bv)
      (for-each (lambda (name meta n)
                  (write-elf-symbol bv (* n size)
                                    endianness word-size
                                    (make-elf-symbol
                                     #:name name
                                     ;; Symbol value and size are measured in
                                     ;; bytes, not u32s.
                                     #:value (meta-low-pc meta)
                                     #:size (- (meta-high-pc meta)
                                               (meta-low-pc meta))
                                     #:type STT_FUNC
                                     #:visibility STV_HIDDEN
                                     #:shndx (elf-section-index
                                              text-section))))
                names meta (iota n)))

    (let ((strtab (make-object asm '.strtab
                               (string-table-size strtab)
                               (string-table-writer strtab)
                               '() '()
                               #:type SHT_STRTAB #:flags 0)))
      (values (make-object asm '.symtab
                           (* n size) write-symbols!
                           '() '()
                           #:type SHT_SYMTAB #:flags 0 #:entsize size
                           #:link (elf-section-index
                                   (linker-object-section strtab)))
              strtab))))

;;; The .guile.arities section describes the arities that a function can
;;; have.  It is in two parts: a sorted array of headers describing
;;; basic arities, and an array of links out to a string table (and in
;;; the case of keyword arguments, to the data section) for argument
;;; names.  The whole thing is prefixed by a uint32 indicating the
;;; offset of the end of the headers array.
;;;
;;; The arity headers array is a packed array of structures of the form:
;;;
;;;   struct arity_header {
;;;     uint32_t low_pc;
;;;     uint32_t high_pc;
;;;     uint32_t offset;
;;;     uint32_t flags;
;;;     uint32_t nreq;
;;;     uint32_t nopt;
;;;     uint32_t nlocals;
;;;   }
;;;
;;; All of the offsets and addresses are 32 bits.  We can expand in the
;;; future to use 64-bit offsets if appropriate, but there are other
;;; aspects of bytecode that constrain us to a total image that fits in
;;; 32 bits, so for the moment we'll simplify the problem space.
;;;
;;; The following flags values are defined:
;;;
;;;    #x1: has-rest?
;;;    #x2: allow-other-keys?
;;;    #x4: has-keyword-args?
;;;    #x8: is-case-lambda?
;;;    #x10: is-in-case-lambda?
;;;    #x20: elided-closure?
;;;
;;; Functions with a single arity specify their number of required and
;;; optional arguments in nreq and nopt, and do not have the
;;; is-case-lambda? flag set.  Their "offset" member links to an array
;;; of pointers into the associated .guile.arities.strtab string table,
;;; identifying the argument names.  This offset is relative to the
;;; start of the .guile.arities section.
;;;
;;; If the arity has keyword arguments -- if has-keyword-args? is set in
;;; the flags -- the first uint32 pointed to by offset encodes a link to
;;; the "keyword indices" literal, in the data section.  Then follow the
;;; names for all locals, in order, as uleb128 values.  The required
;;; arguments will be the first locals, followed by the optionals,
;;; followed by the rest argument if if has-rest? is set.  The names
;;; point into the associated string table section.
;;;
;;; Functions with no arities have no arities information present in the
;;; .guile.arities section.
;;;
;;; Functions with multiple arities are preceded by a header with
;;; is-case-lambda? set.  All other fields are 0, except low-pc and
;;; high-pc which should be the bounds of the whole function.  Headers
;;; for the individual arities follow, with the is-in-case-lambda? flag
;;; set.  In this way the whole headers array is sorted in increasing
;;; low-pc order, and case-lambda clauses are contained within the
;;; [low-pc, high-pc] of the case-lambda header.
;;;
;;; Normally the 0th argument is the closure for the function being
;;; called.  However if the function is "well-known" -- all of its call
;;; sites are visible -- then the compiler may elide the closure, and
;;; the 0th argument is the first user-visible argument.

;; Length of the prefix to the arities section, in bytes.
(define arities-prefix-len 4)

;; Length of an arity header, in bytes.
(define arity-header-len (* 7 4))

;; Some helpers.
(define (put-uleb128 port val)
  (let lp ((val val))
    (let ((next (ash val -7)))
      (if (zero? next)
          (put-u8 port val)
          (begin
            (put-u8 port (logior #x80 (logand val #x7f)))
            (lp next))))))

(define (put-sleb128 port val)
  (let lp ((val val))
    (if (<= 0 (+ val 64) 127)
        (put-u8 port (logand val #x7f))
        (begin
          (put-u8 port (logior #x80 (logand val #x7f)))
          (lp (ash val -7))))))

(define (port-position port)
  (seek port 0 SEEK_CUR))

(define-inline (pack-arity-flags has-rest? allow-other-keys?
                                 has-keyword-args? is-case-lambda?
                                 is-in-case-lambda? elided-closure?)
  (logior (if has-rest? (ash 1 0) 0)
          (if allow-other-keys? (ash 1 1) 0)
          (if has-keyword-args? (ash 1 2) 0)
          (if is-case-lambda? (ash 1 3) 0)
          (if is-in-case-lambda? (ash 1 4) 0)
          (if elided-closure? (ash 1 5) 0)))

(define (write-arities asm metas headers names-port strtab)
  (define (write-header pos low-pc high-pc offset flags nreq nopt nlocals)
    (unless (<= (+ nreq nopt) nlocals)
      (error "forgot to emit definition instructions?"))
    (bytevector-u32-set! headers pos low-pc (asm-endianness asm))
    (bytevector-u32-set! headers (+ pos 4) high-pc (asm-endianness asm))
    (bytevector-u32-set! headers (+ pos 8) offset (asm-endianness asm))
    (bytevector-u32-set! headers (+ pos 12) flags (asm-endianness asm))
    (bytevector-u32-set! headers (+ pos 16) nreq (asm-endianness asm))
    (bytevector-u32-set! headers (+ pos 20) nopt (asm-endianness asm))
    (bytevector-u32-set! headers (+ pos 24) nlocals (asm-endianness asm)))
  (define (write-kw-indices kw-indices relocs)
    ;; FIXME: Assert that kw-indices is already interned.
    (if (pair? kw-indices)
        (let ((pos (+ (bytevector-length headers)
                      (port-position names-port)))
              (label (intern-constant asm kw-indices)))
          (put-bytevector names-port #vu8(0 0 0 0))
          (cons (make-linker-reloc 'abs32/1 pos 0 label) relocs))
        relocs))
  (define (write-arity pos arity in-case-lambda? relocs)
    (write-header pos (arity-low-pc arity)
                  (arity-high-pc arity)
                  ;; FIXME: Seems silly to add on bytevector-length of
                  ;; headers, given the arities-prefix.
                  (+ (bytevector-length headers) (port-position names-port))
                  (pack-arity-flags (arity-rest arity)
                                    (arity-allow-other-keys? arity)
                                    (pair? (arity-kw-indices arity))
                                    #f
                                    in-case-lambda?
                                    (not (arity-has-closure? arity)))
                  (length (arity-req arity))
                  (length (arity-opt arity))
                  (length (arity-definitions arity)))
    (let ((relocs (write-kw-indices (arity-kw-indices arity) relocs)))
      ;; Write local names.
      (let lp ((definitions (arity-definitions arity)))
        (match definitions
          (() relocs)
          ((#(name slot representation def) . definitions)
           (let ((sym (if (symbol? name)
                          (string-table-intern! strtab (symbol->string name))
                          0)))
             (put-uleb128 names-port sym)
             (lp definitions)))))
      ;; Now write their definitions.
      (let lp ((definitions (arity-definitions arity)))
        (match definitions
          (() relocs)
          ((#(name slot representation def) . definitions)
           (put-uleb128 names-port def)
           (let ((tag (case representation
                        ((scm) 0)
                        ((f64) 1)
                        ((u64) 2)
                        ((s64) 3)
                        ((ptr code) 4)
                        (else (error "what!" representation)))))
             (put-uleb128 names-port (logior (ash slot 3) tag)))
           (lp definitions))))))
  (let lp ((metas metas) (pos arities-prefix-len) (relocs '()))
    (match metas
      (()
       (unless (= pos (bytevector-length headers))
         (error "expected to fully fill the bytevector"
                pos (bytevector-length headers)))
       relocs)
      ((meta . metas)
       (match (meta-arities meta)
         (() (lp metas pos relocs))
         ((arity)
          (lp metas
              (+ pos arity-header-len)
              (write-arity pos arity #f relocs)))
         (arities
          ;; Write a case-lambda header, then individual arities.
          ;; The case-lambda header's offset link is 0.
          (write-header pos (meta-low-pc meta) (meta-high-pc meta) 0
                        (pack-arity-flags #f #f #f #t #f #f) 0 0 0)
          (let lp* ((arities arities) (pos (+ pos arity-header-len))
                    (relocs relocs))
            (match arities
              (() (lp metas pos relocs))
              ((arity . arities)
               (lp* arities
                    (+ pos arity-header-len)
                    (write-arity pos arity #t relocs)))))))))))

(define (link-arities asm)
  (define (meta-arities-header-size meta)
    (define (lambda-size arity)
      arity-header-len)
    (define (case-lambda-size arities)
      (fold +
            arity-header-len            ;; case-lambda header
            (map lambda-size arities))) ;; the cases
    (match (meta-arities meta)
      (() 0)
      ((arity) (lambda-size arity))
      (arities (case-lambda-size arities))))

  (let* ((endianness (asm-endianness asm))
         (metas (reverse (asm-meta asm)))
         (header-size (fold (lambda (meta size)
                              (+ size (meta-arities-header-size meta)))
                            arities-prefix-len
                            metas))
         (strtab (make-string-table))
         (headers (make-bytevector header-size 0)))
    (bytevector-u32-set! headers 0 (bytevector-length headers) endianness)
    (let-values (((names-port get-name-bv) (open-bytevector-output-port)))
      (let* ((relocs (write-arities asm metas headers names-port strtab))
             (name-bv (get-name-bv))
             (strtab (make-object asm '.guile.arities.strtab
                                  (string-table-size strtab)
                                  (string-table-writer strtab)
                                  '() '()
                                  #:type SHT_STRTAB #:flags 0)))
        (values (make-object asm '.guile.arities
                             (+ header-size (bytevector-length name-bv))
                             (lambda (bv)
                               ;; FIXME: Avoid extra allocation + copy.
                               (bytevector-copy! headers 0 bv 0
                                                 header-size)
                               (bytevector-copy! name-bv 0 bv header-size
                                                 (bytevector-length name-bv)))
                             relocs '()
                             #:type SHT_PROGBITS #:flags 0
                             #:link (elf-section-index
                                     (linker-object-section strtab)))
                strtab)))))

;;;
;;; The .guile.docstrs section is a packed, sorted array of (pc, str)
;;; values.  Pc and str are both 32 bits wide.  (Either could change to
;;; 64 bits if appropriate in the future.)  Pc is the address of the
;;; entry to a program, relative to the start of the text section, in
;;; bytes, and str is an index into the associated .guile.docstrs.strtab
;;; string table section.
;;;

;; The size of a docstrs entry, in bytes.
(define docstr-size 8)

(define (link-docstrs asm)
  (define (find-docstrings)
    (filter-map (lambda (meta)
                  (define (is-documentation? pair)
                    (eq? (car pair) 'documentation))
                  (let* ((props (meta-properties meta))
                         (tail (find-tail is-documentation? props)))
                    (and tail
                         (not (find-tail is-documentation? (cdr tail)))
                         (string? (cdar tail))
                         (cons (meta-low-pc meta) (cdar tail)))))
                (reverse (asm-meta asm))))
  (let* ((endianness (asm-endianness asm))
         (strtab (make-string-table))
         (docstrings (map (match-lambda
                            ((pc . str)
                             (cons pc (string-table-intern! strtab str))))
                          (find-docstrings))))
    (define (write-docstrings! bv)
      (fold (lambda (pair pos)
              (match pair
                ((pc . string-pos)
                 (bytevector-u32-set! bv pos pc endianness)
                 (bytevector-u32-set! bv (+ pos 4)
                                      string-pos
                                      endianness)
                 (+ pos docstr-size))))
            0
            docstrings))

    (let ((strtab (make-object asm '.guile.docstrs.strtab
                               (string-table-size strtab)
                               (string-table-writer strtab)
                               '() '()
                               #:type SHT_STRTAB #:flags 0)))
      (values (make-object asm '.guile.docstrs
                           (* (length docstrings) docstr-size)
                           write-docstrings!
                           '() '()
                           #:type SHT_PROGBITS #:flags 0
                           #:link (elf-section-index
                                   (linker-object-section strtab)))
              strtab))))

;;;
;;; The .guile.procprops section is a packed, sorted array of (pc, addr)
;;; values.  Pc and addr are both 32 bits wide.  (Either could change to
;;; 64 bits if appropriate in the future.)  Pc is the address of the
;;; entry to a program, relative to the start of the text section, and
;;; addr is the address of the associated properties alist, relative to
;;; the start of the ELF image.
;;;
;;; Since procedure properties are stored in the data sections, we need
;;; to link the procedures property section first.  (Note that this
;;; constraint does not apply to the arities section, which may
;;; reference the data sections via the kw-indices literal, because
;;; assembling the text section already makes sure that the kw-indices
;;; are interned.)
;;;

;; The size of a procprops entry, in bytes.
(define procprops-size 8)

(define (link-procprops asm)
  (define (assoc-remove-one alist key value-pred)
    (match alist
      (() '())
      ((((? (lambda (x) (eq? x key))) . value) . alist)
       (if (value-pred value)
           alist
           (acons key value alist)))
      (((k . v) . alist)
       (acons k v (assoc-remove-one alist key value-pred)))))
  (define (props-without-name-or-docstring meta)
    (assoc-remove-one
     (assoc-remove-one (meta-properties meta) 'name (lambda (x) #t))
     'documentation
     string?))
  (define (find-procprops)
    (filter-map (lambda (meta)
                  (let ((props (props-without-name-or-docstring meta)))
                    (and (pair? props)
                         (cons (meta-low-pc meta) props))))
                (reverse (asm-meta asm))))
  (let* ((endianness (asm-endianness asm))
         (procprops (find-procprops))
         (size (* (length procprops) procprops-size)))
    (define (write-procprops! bv)
      (let lp ((procprops procprops) (pos 0))
        (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))))))

    (make-object asm '.guile.procprops
                 size write-procprops!
                 relocs '()
                 #:type SHT_PROGBITS #:flags 0)))

;;;
;;; The DWARF .debug_info, .debug_abbrev, .debug_str, and .debug_loc
;;; sections provide line number and local variable liveness
;;; information.  Their format is defined by the DWARF
;;; specifications.
;;;

(define (asm-language asm)
  ;; FIXME: Plumb language through to the assembler.
  'scheme)

;; -> 5 values: .debug_info, .debug_abbrev, .debug_str, .debug_loc, .debug_lines
(define (link-debug asm)
  (define (put-s8 port val)
    (let ((bv (make-bytevector 1)))
      (bytevector-s8-set! bv 0 val)
      (put-bytevector port bv)))

  (define (put-u16 port val)
    (let ((bv (make-bytevector 2)))
      (bytevector-u16-set! bv 0 val (asm-endianness asm))
      (put-bytevector port bv)))

  (define (put-u32 port val)
    (let ((bv (make-bytevector 4)))
      (bytevector-u32-set! bv 0 val (asm-endianness asm))
      (put-bytevector port bv)))

  (define (put-u64 port val)
    (let ((bv (make-bytevector 8)))
      (bytevector-u64-set! bv 0 val (asm-endianness asm))
      (put-bytevector port bv)))

  (define (meta->subprogram-die meta)
    `(subprogram
      (@ ,@(cond
            ((meta-name meta)
             => (lambda (name) `((name ,(symbol->string name)))))
            (else
             '()))
         (low-pc ,(meta-label meta))
         (high-pc ,(- (meta-high-pc meta) (meta-low-pc meta))))))

  (define (make-compile-unit-die asm)
    `(compile-unit
      (@ (producer ,(string-append "Guile " (version)))
         (language ,(asm-language asm))
         (low-pc .rtl-text)
         (high-pc ,(asm-pos asm))
         (stmt-list 0))
      ,@(map meta->subprogram-die (reverse (asm-meta asm)))))

  (let-values (((die-port get-die-bv) (open-bytevector-output-port))
               ((die-relocs) '())
               ((abbrev-port get-abbrev-bv) (open-bytevector-output-port))
               ;; (tag has-kids? attrs forms) -> code
               ((abbrevs) vlist-null)
               ((strtab) (make-string-table))
               ((line-port get-line-bv) (open-bytevector-output-port))
               ((line-relocs) '())
               ;; file -> code
               ((files) vlist-null))

    (define (write-abbrev code tag has-children? attrs forms)
      (put-uleb128 abbrev-port code)
      (put-uleb128 abbrev-port (tag-name->code tag))
      (put-u8 abbrev-port (children-name->code (if has-children? 'yes 'no)))
      (for-each (lambda (attr form)
                  (put-uleb128 abbrev-port (attribute-name->code attr))
                  (put-uleb128 abbrev-port (form-name->code form)))
                attrs forms)
      (put-uleb128 abbrev-port 0)
      (put-uleb128 abbrev-port 0))

    (define (intern-abbrev tag has-children? attrs forms)
      (let ((key (list tag has-children? attrs forms)))
        (match (vhash-assoc key abbrevs)
          ((_ . code) code)
          (#f (let ((code (1+ (vlist-length abbrevs))))
                (set! abbrevs (vhash-cons key code abbrevs))
                (write-abbrev code tag has-children? attrs forms)
                code)))))

    (define (intern-file file)
      (match (vhash-assoc file files)
        ((_ . code) code)
        (#f (let ((code (1+ (vlist-length files))))
              (set! files (vhash-cons file code files))
              code))))

    (define (write-sources)
      ;; Choose line base and line range values that will allow for an
      ;; address advance range of 16 words.  The special opcode range is
      ;; from 10 to 255, so 246 values.
      (define base -4)
      (define range 15)
      (define min-inc 4) ; Minimum PC increment.

      (let lp ((sources (asm-sources asm)) (out '()))
        (match sources
          (((pc . location) . sources)
           (let-values (((file line col)
                         ;; Usually CPS records contain a "source
                         ;; vector" coming from tree-il, but some might
                         ;; contain a source property alist.
                         (match location
                           (#(file line col) (values file line col))
                           (lst (values (assq-ref lst 'filename)
                                        (assq-ref lst 'line)
                                        (assq-ref lst 'column))))))
             (lp sources
                 ;; Guile line and column numbers are 0-indexed, but
                 ;; they are 1-indexed for DWARF.
                 (if (and line col)
                     (cons (list pc
                                 (if (string? file) (intern-file file) 0)
                                 (1+ line)
                                 (1+ col))
                           out)
                     out))))
          (()
           ;; Compilation unit header for .debug_line.  We write in
           ;; DWARF 2 format because more tools understand it than DWARF
           ;; 4, which incompatibly adds another field to this header.

           (put-u32 line-port 0) ; Length; will patch later.
           (put-u16 line-port 2) ; DWARF 2 format.
           (put-u32 line-port 0) ; Prologue length; will patch later.
           (put-u8 line-port min-inc) ; Minimum instruction length: 4 bytes.
           (put-u8 line-port 1) ; Default is-stmt: true.

           (put-s8 line-port base) ; Line base.  See the DWARF standard.
           (put-u8 line-port range) ; Line range.  See the DWARF standard.
           (put-u8 line-port 10) ; Opcode base: the first "special" opcode.

           ;; A table of the number of uleb128 arguments taken by each
           ;; of the standard opcodes.
           (put-u8 line-port 0) ; 1: copy
           (put-u8 line-port 1) ; 2: advance-pc
           (put-u8 line-port 1) ; 3: advance-line
           (put-u8 line-port 1) ; 4: set-file
           (put-u8 line-port 1) ; 5: set-column
           (put-u8 line-port 0) ; 6: negate-stmt
           (put-u8 line-port 0) ; 7: set-basic-block
           (put-u8 line-port 0) ; 8: const-add-pc
           (put-u8 line-port 1) ; 9: fixed-advance-pc

           ;; Include directories, as a zero-terminated sequence of
           ;; nul-terminated strings.  Nothing, for the moment.
           (put-u8 line-port 0)

           ;; File table.  For each file that contributes to this
           ;; compilation unit, a nul-terminated file name string, and a
           ;; uleb128 for each of directory the file was found in, the
           ;; modification time, and the file's size in bytes.  We pass
           ;; zero for the latter three fields.
           (vlist-fold-right
            (lambda (pair seed)
              (match pair
                ((file . code)
                 (put-bytevector line-port (string->utf8 file))
                 (put-u8 line-port 0)
                 (put-uleb128 line-port 0) ; directory
                 (put-uleb128 line-port 0) ; mtime
                 (put-uleb128 line-port 0))) ; size
              seed)
            #f
            files)
           (put-u8 line-port 0) ; 0 byte terminating file list.

           ;; Patch prologue length.
           (let ((offset (port-position line-port)))
             (seek line-port 6 SEEK_SET)
             (put-u32 line-port (- offset 10))
             (seek line-port offset SEEK_SET))

           ;; Now write the statement program.
           (let ()
             (define (extended-op opcode payload-len)
               (put-u8 line-port 0)                     ; extended op
               (put-uleb128 line-port (1+ payload-len)) ; payload-len + opcode
               (put-uleb128 line-port opcode))
             (define (set-address sym)
               (define (add-reloc! kind)
                 (set! line-relocs
                       (cons (make-linker-reloc kind
                                                (port-position line-port)
                                                0
                                                sym)
                             line-relocs)))
               (match (asm-word-size asm)
                 (4
                  (extended-op 2 4)
                  (add-reloc! 'abs32/1)
                  (put-u32 line-port 0))
                 (8
                  (extended-op 2 8)
                  (add-reloc! 'abs64/1)
                  (put-u64 line-port 0))))
             (define (end-sequence pc)
               (let ((pc-inc (/ (- (asm-pos asm) pc) min-inc)))
                 (put-u8 line-port 2)   ; advance-pc
                 (put-uleb128 line-port pc-inc))
               (extended-op 1 0))
             (define (advance-pc pc-inc line-inc)
               (let ((spec (+ (- line-inc base)
                              (* (/ pc-inc min-inc) range)
                              10)))
                 (cond
                  ((or (< line-inc base) (>= line-inc (+ base range)))
                   (advance-line line-inc)
                   (advance-pc pc-inc 0))
                  ((<= spec 255)
                   (put-u8 line-port spec))
                  ((< spec 500)
                   (put-u8 line-port 8) ; const-advance-pc
                   (advance-pc (- pc-inc (* (floor/ (- 255 10) range) min-inc))
                               line-inc))
                  (else
                   (put-u8 line-port 2) ; advance-pc
                   (put-uleb128 line-port (/ pc-inc min-inc))
                   (advance-pc 0 line-inc)))))
             (define (advance-line inc)
               (put-u8 line-port 3)
               (put-sleb128 line-port inc))
             (define (set-file file)
               (put-u8 line-port 4)
               (put-uleb128 line-port file))
             (define (set-column col)
               (put-u8 line-port 5)
               (put-uleb128 line-port col))

             (set-address '.rtl-text)

             (let lp ((in out) (pc 0) (file 1) (line 1) (col 0))
               (match in
                 (()
                  (when (null? out)
                    ;; There was no source info in the first place.  Set
                    ;; file register to 0 before adding final row.
                    (set-file 0))
                  (end-sequence pc))
                 (((pc* file* line* col*) . in*)
                  (cond
                   ((and (eqv? file file*) (eqv? line line*) (eqv? col col*))
                    (lp in* pc file line col))
                   (else
                    (unless (eqv? col col*)
                      (set-column col*))
                    (unless (eqv? file file*)
                      (set-file file*))
                    (advance-pc (- pc* pc) (- line* line))
                    (lp in* pc* file* line* col*)))))))))))

    (define (compute-code attr val)
      (match attr
        ('name (string-table-intern! strtab val))
        ('low-pc val)
        ('high-pc val)
        ('producer (string-table-intern! strtab val))
        ('language (language-name->code val))
        ('stmt-list val)))

    (define (choose-form attr val code)
      (cond
       ((string? val) 'strp)
       ((eq? attr 'stmt-list) 'sec-offset)
       ((eq? attr 'low-pc) 'addr)
       ((exact-integer? code)
        (cond
         ((< code 0) 'sleb128)
         ((<= code #xff) 'data1)
         ((<= code #xffff) 'data2)
         ((<= code #xffffffff) 'data4)
         ((<= code #xffffffffffffffff) 'data8)
         (else 'uleb128)))
       (else (error "unhandled case" attr val code))))

    (define (add-die-relocation! kind sym)
      (set! die-relocs
            (cons (make-linker-reloc kind (port-position die-port) 0 sym)
                  die-relocs)))

    (define (write-value code form)
      (match form
        ('data1 (put-u8 die-port code))
        ('data2 (put-u16 die-port code))
        ('data4 (put-u32 die-port code))
        ('data8 (put-u64 die-port code))
        ('uleb128 (put-uleb128 die-port code))
        ('sleb128 (put-sleb128 die-port code))
        ('addr
         (match (asm-word-size asm)
           (4
            (add-die-relocation! 'abs32/1 code)
            (put-u32 die-port 0))
           (8
            (add-die-relocation! 'abs64/1 code)
            (put-u64 die-port 0))))
        ('sec-offset (put-u32 die-port code))
        ('strp (put-u32 die-port code))))

    (define (write-die die)
      (match die
        ((tag ('@ (attrs vals) ...) children ...)
         (let* ((codes (map compute-code attrs vals))
                (forms (map choose-form attrs vals codes))
                (has-children? (not (null? children)))
                (abbrev-code (intern-abbrev tag has-children? attrs forms)))
           (put-uleb128 die-port abbrev-code)
           (for-each write-value codes forms)
           (when has-children?
             (for-each write-die children)
             (put-uleb128 die-port 0))))))

    (define (copy-writer source)
      (lambda (bv)
        (bytevector-copy! source 0 bv 0
                          (bytevector-length source))))

    ;; Compilation unit header.
    (put-u32 die-port 0) ; Length; will patch later.
    (put-u16 die-port 4) ; DWARF 4.
    (put-u32 die-port 0) ; Abbrevs offset.
    (put-u8 die-port (asm-word-size asm)) ; Address size.

    (write-die (make-compile-unit-die asm))

    ;; Terminate the abbrevs list.
    (put-uleb128 abbrev-port 0)

    (write-sources)

    (values (let ((bv (get-die-bv)))
              ;; Patch DWARF32 length.
              (bytevector-u32-set! bv 0 (- (bytevector-length bv) 4)
                                   (asm-endianness asm))
              (make-object asm '.debug_info
                           (bytevector-length bv)
                           (copy-writer bv)
                           die-relocs '()
                           #:type SHT_PROGBITS #:flags 0))
            (let ((bv (get-abbrev-bv)))
              (make-object asm '.debug_abbrev
                           (bytevector-length bv) (copy-writer bv)
                           '() '()
                           #:type SHT_PROGBITS #:flags 0))
            (make-object asm '.debug_str
                         (string-table-size strtab)
                         (string-table-writer strtab)
                         '() '()
                         #:type SHT_PROGBITS #:flags 0)
            (make-object asm '.debug_loc
                         0 (lambda (bv) #t)
                         '() '()
                         #:type SHT_PROGBITS #:flags 0)
            (let ((bv (get-line-bv)))
              ;; Patch DWARF32 length.
              (bytevector-u32-set! bv 0 (- (bytevector-length bv) 4)
                                   (asm-endianness asm))
              (make-object asm '.debug_line
                           (bytevector-length bv) (copy-writer bv)
                           line-relocs '()
                           #:type SHT_PROGBITS #:flags 0)))))

(define (link-objects asm)
  (let*-values (;; Link procprops before constants, because it probably
                ;; interns more constants.
                ((procprops) (link-procprops asm))
                ((ro rw rw-init) (link-constants asm))
                ;; Link text object after constants, so that the
                ;; constants initializer gets included.
                ((text) (link-text-object asm))
                ((frame-maps) (link-frame-maps asm))
                ((dt) (link-dynamic-section asm text rw rw-init frame-maps))
                ((symtab strtab) (link-symtab (linker-object-section text) asm))
                ((arities arities-strtab) (link-arities asm))
                ((docstrs docstrs-strtab) (link-docstrs asm))
                ((dinfo dabbrev dstrtab dloc dline) (link-debug asm))
                ;; This needs to be linked last, because linking other
                ;; sections adds entries to the string table.
                ((shstrtab) (link-shstrtab asm)))
    (filter identity
            (list text ro frame-maps rw dt symtab strtab
                  arities arities-strtab
                  docstrs docstrs-strtab procprops
                  dinfo dabbrev dstrtab dloc dline
                  shstrtab))))


