(herald (assembler as t 85)
        (env tsys (assembler ib) (assembler as_open)))

;;; ----------------------------------------------------------------
;;; Interface to the assembler

;;; ---------------- Emissions
                                                              
(define (as-emit ib fg)
  (solidify-fg fg)
  (push (ib-instructions ib) fg))

;;; see as_open for what to pass as JOP

(define (as-emit-jump section ib jop 1tag 0tag)
    (set (ib-jump-op ib) jop)
    (if 1tag (set (ib-1tag ib) (as-jump-tag section 1tag ib)))
    (if 0tag (set (ib-0tag ib) (as-jump-tag section 0tag ib))) )

;;; Returns tag that can be used to access emitted data.  e.g.  
;;;   (as-emit-somewhere (vax-d-floating-bits 1.2)) 

(define (as-emit-somewhere section data-fg)
    (let ((ib (as-data-tag section data-fg)))
        (as-emit ib data-fg)
        ib))

;;; Comments are keyed by pairs in the ib-instructions list, so the list of
;;; comments is tacked on to the last thing emitted.  

(define (as-comments ib the-comments)
   (let ((i's (ib-instructions ib)))
     (let ((key (if (null? i's) '() i's)))
       (let ((c's (ib-comments ib)))
          (cond ((and (pair? c's) (pair? (car c's)) (eq? (caar c's) key))
                 (modify (cdr (car c's)) (lambda (l) (append the-comments l))))
                (else
                 (set (ib-comments ib) `((,i's ,@the-comments) ,@c's))))))))

(define (as-comment ib the-comment)
  (as-comments ib (list the-comment)))

;;;----------------- Statistics

(define statistics-field-names
 '(ib sdf align mark clean dirty bytes))

(define (print-section-statistics section port)
  (format port "~g~%"
          `(as . ,(map list
                       statistics-field-names
                       (assembly-section-stats section)))))

;;; ---------------- Label management
                 
;;; Return ib associated with the label, make (& return) a new ib if no
;;;   such label exists.

(define (as-tag section label)
  (let ((tags (assembly-section-labels section)))
    (cond ((table-entry tags label)
           => identity)
          (else
           (let ((ib (make-ib)))
             (push (assembly-section-ibs section) ib)
             (set (table-entry tags label) ib)
             ib)))))

(define (new-as-tag section label)
  (let ((tags (assembly-section-labels section)))
    (cond ((table-entry tags label)
           => (lambda (ib)
                (if (not (null? (ib-instructions ib)))
                    (format (terminal-output) "duplicate label: ~s" label))
                ib))
          (else
           (let ((ib (make-ib)))
             (push (assembly-section-ibs section) ib)
             (set (table-entry tags label) ib)
             ib)))))

;;; ... and record that there is a jump from the jumper to the label

(define (as-jump-tag section label jumper-ib)
  (let ((target-ib (as-tag section label)))
    (push (ib-jumped-to-by target-ib) jumper-ib)
    target-ib))

;;; ... and record that the label is used as a data reference

(define (as-data-tag section label)
  (let ((target-ib (as-tag section label)))
    (set (ib-data-label? target-ib) t)
    target-ib))

;;; Given label, return its offset in the code

(define (label-offset section label)
  (cond ((table-entry (assembly-section-labels section) label)
         => (lambda (n)  (ib-address n)))
        (else '#f)))

(define as-label-offset label-offset)
                                          
;;; Assemble a list of IBs into a bytev vector, returns a BITS structure.
;;; Fixup output to user.  

;;; ---------------- The main line.

;;; Given an section, return a byte vector of the assembled result.

(define (new-assemble section)
  (let* ((ibs (reverse (assembly-section-ibs section)))
         (machine (assembly-section-machine section))
         (ibv (ib-order ibs)))
    
    (set (assembly-section-ib-vector section) ibv)
    
    ;; consistency check
    (let ((ibv-length (vector-length ibv)))
      (do ((i 0 (fx+ i 1)))
          ((fx>= i ibv-length) '*)
        (if (or (not (ib? (vref ibv i)))
                (fxn= i (ib-pos (vref ibv i))))
            (bug "ibs not ordered correctly"))))
    
    (branchify ibv machine)
    (receive (mark-count span-count) 
             (count-spans ibv)
      (receive (min-size sdfs marks)
               (marker ibv mark-count span-count)
        (let* ((mini-iterations (minimize-displacements sdfs))  ;; nia loses
               (max-adj (fixup-labels ibv sdfs marks)))
          (receive (b bits-length)
                   (bits ibv (fx+ min-size max-adj) machine)
            (set (assembly-section-stats section)
                 (list (vector-length ibv)          ; ib
                       (vector-length sdfs)         ; sdf
                       (count-align-sdfs sdfs)      ; align
                       (vector-length marks)        ; mark
                       (car mini-iterations)        ; clean
                       (cdr mini-iterations)        ; dirty
                       bits-length))                ; bytes
            (set (assembly-section-bits section) b)
            section))))))

(define assemble new-assemble)