(herald (assembler mini t 11)
        (env tsys (assembler as_open) (assembler mark) (assembler ib)))

;;; ----------------------------------------------------------------
;;; Minimize span dependent fields

;;; Implements Szymanski's algorithm for span dependent instruction 
;;; computation.  April 1978, CACM, pp300-308.

(define (minimize-displacements sdfs)
    (receive (first last) (initialize-sdfs sdfs)
      (compute-sdf-widths sdfs first last)))

(define (fixup-labels ibv sdfs marks)
    (let ((adjs (compute-adjustments sdfs)))
      (fixup-ibs ibv adjs sdfs)
      (adjust-adjustments-for-alignments adjs sdfs)
      (fixup-marks marks adjs) 
                                                   
      ;; womp final width and displacement into the fg
      (walk-vector (lambda (sdf) 
                     (cond ((not (empty? (sdf-span sdf)))
                            (let ((ss (sdf-static sdf))
                                  (vars (sdf-vars sdf)))
                              (set (vref vars (sdf-static-width-var ss))
                                   (sdf-width sdf))
                              (set (vref vars (sdf-static-displ-var ss))
                                   (sdf-span sdf))))))
                   sdfs)

      ;; return maximum adjustment (amount of increase in output size)
      (let ((last-adj-i (fx- (vector-length adjs) 1)))
         (if (fx< last-adj-i 0) 
             0 
             (vref adjs last-adj-i)))
      ))

;;; The data structures have been set up by 'count' and 'mark'

;;; Initialize sdf structures:
;;;  - set 'next-dirty' slot of prev sdf to this sdf
;;;  - compute initial spans
;;;  - return the first and last dirty sdfs.

(define (initialize-sdfs sdfs)
  (let ((sdfs-length (vector-length sdfs))
        (first nil))
    (iterate loop ((i 0) (prev nil))
        (cond ((fx>= i sdfs-length) (return first prev))
              (else
               (let ((sdf (vref sdfs i)))
                 (cond ((empty? (sdf-span sdf))   ; an alignment sdf
                        (loop (fx+ i 1)  prev))
                       (else                                     
                        (initialize-span sdfs i sdf)
                        (cond (prev (set (sdf-next-dirty prev) sdf))
                              (else (set first sdf)))
                        (loop (fx+ i 1) sdf)))))))))
       
;;; Initialize a single sdf.  For a given sdf, add it to the crossers
;;; list of all sdfs that it crosses.

(define (initialize-span sdfs index sdf)
  (let ((span (fx- (ib-address (sdf-label sdf)) 
                   (mark-address (sdf-mark sdf))))
        (label-sdf# (ib-sdf-number (sdf-label sdf)))
        (mark-sdf# (mark-sdf-position (sdf-mark sdf))))
    
    (set (sdf-backwards? sdf) (fx>= mark-sdf# label-sdf#))
    (set (sdf-span sdf) span)
    
    ;; consistency check
    (cond ((or (and (fx> (sdf-span sdf) 0) (sdf-backwards? sdf))
               (and (fx< (sdf-span sdf) 0) (not (sdf-backwards? sdf))))
           (bug "inconsistent sdf ~s ~%" sdf)))
    
    (let ((dest (ib-sdf-number (sdf-label sdf))))
      (receive (start end) 
               (cond ((fx> dest index) (return (fx+ index 1) dest)) ;forward
                     (else (return dest index)))
        (do ((i start (fx+ i 1)))
            ((fx>= i end) sdf)
          (push (sdf-crossers (vref sdfs i)) sdf))))
    (set (sdf-width sdf) (sdf-static-first-width (sdf-static sdf)))))

;;; Main loop for computing widths.
;;; Take next sdf off list of (possibly) dirty sdfs.  If the width
;;; of the sdf is big enough to hold its current value, mark it clean;
;;; otherwise, change the width, mark sdfs that cross this one dirty,
;;; and then mark this one clean.

(define (compute-sdf-widths sdfs next last)
   (iterate loop ((next next) (last last) (clean-i 0) (dirty-i 0))
      (cond ((null? next) (cons clean-i dirty-i))   ; only informational
            (else
             (let* ((sdf next)
                    (cur-w (sdf-width sdf)))
               (receive (new-w maybe-new-span)
                        ((sdf-selector sdf) cur-w (sdf-span sdf))
                 ;; width changed?
                 (cond ((fx> new-w cur-w) 
                        (set (sdf-width sdf) new-w)
                        ;; if width didn't change, span shouldn't change.
                        (set (sdf-span sdf) maybe-new-span)
                        (let ((new-last (dirty-crossers sdf (fx- new-w cur-w) last)))
                           (loop (swap (sdf-next-dirty next) 0) 
                                 new-last
                                 (fx+ dirty-i 1)
                                 clean-i)))
                       (else
                        (loop (swap (sdf-next-dirty next) 0) 
                              last 
                              dirty-i
                              (fx+ clean-i 1))))
                 )))))) 
                 
;;; Utility for adjusting spans in all sdfs that span an sdf that has changed.

(define (dirty-crossers sdf delta current-last)
  ;; list affected sdf's as dirty
  (iterate set-dirty ((dirts (sdf-crossers sdf))
                      (new-last current-last))
    (cond ((null? dirts) new-last)
          (else
           (modify (sdf-span (car dirts))
                   (lambda (s)     
                     (cond ((sdf-backwards? (car dirts)) (fx- s delta))
                           (else (fx+ s delta))) ))
           (cond ;; was clean?
            ((eq? 0 (sdf-next-dirty (car dirts))) 
             (set (sdf-next-dirty new-last) (car dirts))
             (set (sdf-next-dirty (car dirts)) nil)
             (set-dirty (cdr dirts) (car dirts)))
            ;; already dirty
            (else  
             (set-dirty (cdr dirts) new-last)))))))
                                  
;;; Alignment adjustments happen at the end, and are not subjected
;;; to minimization.

(define (adjust-align-crossers sdf delta)
  (let ((xers (sdf-crossers sdf)))
    (if (not (empty? (sdf-span sdf))) (error "non-alignment sdf"))
    (do ((xers xers (cdr xers)))
        ((null? xers) nil)
      (modify (sdf-span (car xers))
              (lambda (s) 
                (cond ((sdf-backwards? (car xers)) (fx- s delta))
                      (else (fx+ s delta))))))))

;;; After the sdf withs have been computed, we have to go back and adjust all 
;;; the label (and mark) address. Some addresses will have to be adjusted for 
;;; alignment. 'mark' inserted the maximum possible fill for alignment,
;;; and now we remove whatever is necessary.  Spans of sdf's that cross the
;;; alignments must be adjusted.
                                                                 
;;; Compute adjustments table: eg, a label is preceded by 6 sdfs, so the 6th 
;;; element of this table will give the amount to adjust the label by.
;;; This leaves the 0th slot as a dummy (this is a feature).

(define (compute-adjustments sdfs)
  (let* ((sdfs-length (vector-length sdfs))
         (adj-length (fx+ sdfs-length 1))
         (adjustments (make-vector adj-length)))
    (set (vref adjustments 0) 0)
    (iterate loop ((i 0) (accum-adjustment 0))
      (cond ((fx>= i sdfs-length) adjustments)
            (else
              (let ((sdf (vref sdfs i)))             
                (cond ;; align sdfs don't count
                      ((empty? (sdf-span sdf))
                       (set (vref adjustments (fx+ i 1)) accum-adjustment)
                       (loop (fx+ i 1) accum-adjustment))
                      (else
                       (let ((adj (fx+ accum-adjustment
                                       (fx- (sdf-width sdf)
                                            (sdf-static-first-width
                                             (sdf-static sdf))))))
                         (set (vref adjustments (fx+ i 1)) adj)
                         (loop (fx+ i 1) adj))))))))))

;;; Apply the adjustments to the labels (IBs).  Align each
;;; after adjustment, and accumulate the adjustments made for alignment.

;; Hacko alignment stuff.

  ;;; M is one less than multiple being align to.  The multiple must be
  ;;; a power of 2.  So, to do quadword alignment, M is 7

  ;;; Except that we do everything in terms of bits, not bytes, so M is 63

  (define-integrable (as-align lc m)
    (fixnum-logand (fx+ lc m) (fixnum-lognot m)))

  ;;; OFFSET is number of units past a boundry (as determined my M)

  (define-integrable (offset-align lc m offset)
    (cond (offset 
               (fx+ offset (as-align (fx- lc offset) m)))
          (else
           (as-align lc m))))
                                                       
;;; The goal here is to set the address of each IB to the corrected
;;; value.  Ignoring alignments, this is straigtforward - just add the
;;; amount from the appropriate slot in the adjustments table.  If
;;; we do have to deal with alignment,  we compute that amount
;;; of shrinkage, record it in the alignment sdf, and add the shrinkage
;;; to the accumulating 'align-error'

;;; [side note: some sdfs are in the vector of sdfs only to indicate that an
;;;  alignment happens at that point.  When we adjust an ib by reducing the 
;;;  number of alignment bytes preceeding it, we record the number of
;;;  bytes eliminated in the alignment sdf width field. ]

;;; The only reason for recording the alignment shrinkage in the alignment
;;; sdfs, is that we must fix up the mark addresses also.  It is not
;;; possible to fixup the adjustments table as you go along, because
;;; you are iterating across the ibs, not the adjustments.
;;; So instead, we save the shrinks, and them apply them all at once
;;; to the adjustments vector by calling 'adjust-adjustments-for-alignments.'
;;; The new adjustments are applied to the marks by calling 'fixup-marks.'

(define (fixup-ibs ibv adj's sdfs)
  (let ((ibv-length (vector-length ibv)))
    (iterate loop ((i 0) (align-error 0))  ; accumulated alignment adj's
       (cond ((fx>= i ibv-length) 'done)
             (else
              (let* ((ib (vref ibv i))
                     (sdf# (ib-sdf-number ib))
                     (ib-fix (fx+ align-error (vref adj's sdf#)))
                     (new-ib-addr (fx+ (ib-address ib) ib-fix))
                     (a (ib-align ib)))
                (cond ((not a)
                       (set (ib-address ib) new-ib-addr)
                       (loop (fx+ i 1) align-error))
                      (else
                       (let* ((re-aligned (offset-align (fx- new-ib-addr (car a))
                                                        (cadr a)
                                                        (caddr a)))
                              (shrink (fx- re-aligned new-ib-addr))
                              (align-sdf (vref sdfs (fx- sdf# 1)))
                              )
                         (if (fx> shrink 0) (error "alignment caused increase"))
                         (set (ib-align ib) (fx+ (car a) shrink))
                         (set (ib-address ib) re-aligned)
                         (set (sdf-width align-sdf) shrink)
                         (adjust-align-crossers align-sdf shrink)
                         (loop (fx+ i 1) (fx+ align-error shrink))
                         )))))))))        


(define (adjust-adjustments-for-alignments adjs sdfs)
  (let ((sdfs-length (vector-length sdfs)))
    (iterate loop ((i 0) (align-error 0))
        ;; because indices info adjs are offset by 1, we can do the
        ;; set here, but it is easier to think about if at the bottom
        (modify (vref adjs i) (lambda (a) (fx+ align-error a)))
        (cond ((fx>= i sdfs-length) 'done)     
              (else
               (let* ((sdf (vref sdfs i))
                      (a (if (empty? (sdf-span sdf)) (sdf-width sdf) 0)))
                 (loop (fx+ i 1) (fx+ align-error a))))))))

(define (fixup-marks marks adjs)
  (if (fxn= (vref adjs 0) 0)
      (error "dummy adjustment slot changed"))
  (let ((len (vector-length marks)))
    (do ((i 0 (fx+ i 1)))             
        ((fx>= i len) 'done)
      (let ((mark (vref marks i)))
        (modify (mark-address mark)
                (lambda (ma)
                  (fx+ ma (vref adjs (mark-sdf-position mark)))))))))