(herald (assembler ib t 11))

;;; ----------------------------------------------------------------
;;; Instruction block ordering, branch insertion

(define-structure-type ib
  pos           ; position of this IB in vector of all IBs
  sdf-number    ; records the sdf number of the align sdf, if any;
                ;  later, it records the number of sdfs that precede 
                ;  this ib. (used only by IB-FOLLOW, IB-ORDER stuff)

  address       ; address of block
                ; *** MULTIPLEXED w/ IB-PENDING-IBS

  align         ; <n> for specific number of bytes, or (<max> <n> <m>)
                ;  where <n> is alignment interval less 1, <m> is offset,
                ;  and <max> is the largest possible amount of space that 
                ;  this alignment will result in.  False means no alignment.

  instructions  ; list of fgs

  jump-op       ; number indicating EQ, GT, etc
  1tag          ; IB to jump to if successful
  0tag          ; IB to jump to if not successful

  next          ; the IB that may or must follow this one, if any.  This slot is 
                ;  for partial ordering IBs (like forcing the IB containing 
                ;  the instructions for a template to follow the IB with the
                ;  template in it; or to get ordering of blocks in a loop right)
                ;  The target of this field must have its POS slot
                ;  set to point to this IB.  If the link is provisional
                ;  then the pos slot should be set to (cons 'maybe <this-ib>)

  comments      ; alist, keyed by pairs taken from the ib-instructions list.
                ;  Comments will be printed after the fg in the car of the pair
                ;  is printed (in a listing).  Comments keyed by the null list
                ;  are printed before anything else.

  jumped-to-by  ; list of ibs that have a jump or fall through to this ib

  data-label?   ; true if this ib is the subject of a "data" reference
                ;   (and therefore can not be eliminated)

  name          ; for listings

  (;handler  
    ((pretty-print self stream)
     (pretty-print-ib self stream))))

(define-integrable ib-pending-ibs ib-address)

(let ((ib (stype-master ib-stype)))
  (set (ib-pos ib) *empty*)

  (set (ib-pending-ibs ib) '())

  (set (ib-align ib) nil)
  (set (ib-instructions ib) '())

  (set (ib-jump-op ib) *empty*)
  (set (ib-1tag ib) *empty*)
  (set (ib-0tag ib) *empty*)

  (set (ib-next ib) *empty*)
  (set (ib-comments ib) '())

  (set (ib-jumped-to-by ib) '())
  (set (ib-data-label?  ib) nil)

  (set (ib-name  ib) *empty*)
  )

;;; ---------------- Printing IBs

(define (pp-ib-as-hash tag str)
  (format str "~c~s" (if (ib-data-label? tag) #\D #\L) (object-hash tag)))

(define (pp-ib-as-name-or-hash tag str)
  (cond ((empty? (ib-name tag))
         (format str "~c~s" (if (ib-data-label? tag) #\D #\L)(object-hash tag)))
        (else
         (format str "~a" (ib-name tag)))))

(define pretty-print-ib pp-ib-as-name-or-hash)

;;; ----------------
     
(define (set-ib-follower first-ib next-ib)
  (let ((next-pos (ib-pos next-ib))
        (first-next (ib-next first-ib)))
    (cond ((not (empty? first-next))
           ;; first has follower, but is it only provisional? 
           (let ((old-back-link (ib-pos first-next)))
             (cond ((and (pair? old-back-link) (eq? (car old-back-link) 'maybe))
                    (set (ib-pos first-next) *empty*))
                   (else
                    (error "~s already has a follower~% (SET-IB-FOLLOWER ~s ~s)"
                           first-ib
                           first-ib
                           next-ib)))))
          ((not (empty? next-pos))
           (cond ((and (pair? next-pos) (eq? (car next-pos) 'maybe))
                  (set (ib-next (cdr next-pos)) *empty*))
                 (else
                  (error "~s already ordered~% (SET-IB-FOLLOWER ~s ~s)"
                         next-ib
                         first-ib
                         next-ib)))))
      (set (ib-next first-ib) next-ib)
      (set (ib-pos next-ib) first-ib)))

(define (maybe-set-ib-follower first-ib next-ib)
    (cond ((and (empty? (ib-pos next-ib))
                (empty? (ib-next first-ib)))
           (set (ib-next first-ib) next-ib)
           (set (ib-pos next-ib) (cons 'maybe first-ib)))))

;;; ----------------------------------------------------------------
;;; Choose branch instructions.  This pass also reverses the instructions.

(define (branchify ibv machine)
  (let ((ibv-length (vector-length ibv))
        (cond-branch (machine-cond-branch machine))
        (uncond-branch (machine-uncond-branch machine))
        (reverse-jump (machine-reverse-jump machine)))
    (do ((i 0 (fx+ i 1)))
        ((fx>= i ibv-length)
         ibv)
      (let ((ib (vref ibv i))
            (fall (cond ((fx< (fx+ i 1) ibv-length) (vref ibv (fx+ i 1)))
                        (else nil))))
        (cond ((empty? (ib-jump-op ib)))
              ((empty? (ib-0tag ib))  ; abs jump
               (cond ((eq? (ib-1tag ib) fall)
                      (set (ib-jump-op ib) 'fall)
                      (set (ib-1tag  ib) *empty*))
                     (else 
                      (set-branch ib (uncond-branch (ib-1tag ib)))
                      )))
              ((eq? fall (ib-0tag ib))
               (set-branch ib (cond-branch (ib-jump-op ib) (ib-1tag ib)))
               (set (ib-0tag ib) 'fall))
              ((eq? fall (ib-1tag ib))
               (set (ib-1tag ib) (ib-0tag ib))
               (modify (ib-jump-op ib) reverse-jump)
               (set-branch ib (cond-branch (ib-jump-op ib) (ib-1tag ib)))
               (set (ib-0tag ib) 'fall))
              ;; neither can fall through, both must jump
              ;; if we knew sizes, we could jump to the closer one
              (else 
               (set-2-branches ib cond-branch uncond-branch)))
        (modify (ib-comments ib) reverse!)
        (modify (ib-instructions ib) reverse!)))))

(define (set-branch ib branch-fg)
  (solidify-fg branch-fg)
  (push (ib-instructions ib) branch-fg))

(define (set-2-branches ib cond-branch uncond-branch)
  (let ((1pos (ib-pos (ib-1tag ib)))
        (0pos (ib-pos (ib-0tag ib)))
        (pos (ib-pos ib)))
    (receive (near far)
             (cond ((fx< (fixnum-abs (fx- pos 1pos))
                         (fixnum-abs (fx- pos 0pos)))
                    (return 1pos 0pos))
                   (else
                    (return 0pos 1pos)))
      (cond ((eq? far (ib-1tag ib))
             (exchange (ib-1tag ib) (ib-0tag ib))
             (modify (ib-jump-op ib) reverse-jump)))
      (set-branch ib (cond-branch (ib-jump-op ib) (ib-1tag ib)))
      (set-branch ib (uncond-branch (ib-0tag ib))))))

;;; ----------------------------------------------------------------
;;; Order instruction blocks -- given a list of ibs in the order generated,
;;; put them into a vector and set the POS field for each.

(define-integrable (ib-free? ib)
  (empty? (ib-pos ib)))

(define-integrable (ib-seen? ib)
  (null? (ib-pos ib)))

(define-integrable (ib-ordered? ib)
  (fixnum? (ib-pos ib)))

(define-integrable (ib-done? ib)
  (and (fixnum? (ib-pos ib)) (fx>= (ib-pos ib) 0)))

(define (first-unordered-ib l)
    (iterate loop ((l l))
        (cond ((null? l) nil)
              ((not (ib-ordered? (car l))) l)
              (else
               (loop (cdr l))))))

(lset *queued-ibs* nil)
(lset *unqueued-ibs* nil)
             
(define (ib-order ibs)
  ;; convert pos slots to a canonical mark for easy checking.
  (walk (lambda (ib) (if (not (ib-free? ib)) (set (ib-pos ib) -1)))
        ibs)
  (bind ((*queued-ibs* 0) (*unqueued-ibs* 0))
    (let ((ibv (make-vector (length ibs)))
          (ibs (first-unordered-ib ibs)))
      (iterate loop ((fall-to (car ibs)) (ibs (cdr ibs)) (pos 0))
        (set (ib-pos fall-to) pos)
        (set (vref ibv pos) fall-to)
        (receive (winner loser)
                 ;; check to see if a next is specified, if not choose one
                 (cond ((empty? (ib-next fall-to))
                        (ib-order-choose fall-to))
                       (else
                        (return (ib-next fall-to) nil)))
          (let ((ibs (cond ((ib-pending-ibs fall-to) 
                            => (lambda (x) (append! x ibs)))
                           (else ibs))))
            (cond (winner
                   (if loser (set (ib-pos loser) nil))  ; mark as seen
                   (loop winner ibs (fx+ pos 1)))
                  (else
                   (let ((ibs (next-free-ib ibs)))
                      (cond ((null? ibs) 
                             (noise "~s IBs queued, ~s IBs unqueued~%" 
                                    *queued-ibs*
                                    *unqueued-ibs*)
                             ibv)
                            (else 
                             (loop (car ibs) (cdr ibs) (fx+ pos 1)))))))))))))

(define (next-free-ib ibs)
  (iterate next-free ((ibs ibs))
    (cond ((null? ibs) ibs)
          (else
           (let ((next (car ibs)))
             (cond ((ib-ordered? next)
                    (next-free (cdr ibs)))
                   ((not (empty? (ib-jump-op next)))
                    ibs)
                   ;; dead end - so try to queue on pending-ibs of some ib
                   (else
                    (let ((froms (ib-jumped-to-by next)))
                      (iterate queue ((froms froms) (q 0) (uq 0))
                         (cond ((null? froms)
                                (set *queued-ibs* (fx+ *queued-ibs* q))
                                (set *unqueued-ibs* (fx+ *unqueued-ibs* uq))
                                (if (fx> q 0) (next-free (cdr ibs)) ibs))
                               ((and (not (ib-done? (car froms)))
                                     (empty? (ib-next (car froms))))
                                ;(format t "queue ~g on ~g~%~%" next (car froms))
                                (push (ib-pending-ibs (car froms)) next)
                                (queue (cdr froms) (fx+ q 1) uq))
                               (else
                                ;(format t "didn't queue on ~g~% pos - ~s~% next - ~s~%~%" (car froms) (ib-pos (car froms)) (ib-next (car froms)))
                                (queue (cdr froms) q (fx+ uq 1)))))))
                   ))))))


;;; Returns 2 values, winner and loser.  If loser is null, then there is
;;; one alternative, if winner is null, there is no alternative.
(define (ib-order-choose ib)
  (let ((0tag (ib-0tag ib))
        (1tag (ib-1tag ib)))
    (cond ((empty? (ib-jump-op ib))
           (return nil nil))
          ((empty? 0tag)
           (return (if (ib-ordered? 1tag) nil 1tag)
                   nil))
          ((and (ib-ordered? 0tag) (not (ib-ordered? 1tag)))
           (return 1tag nil))
          ((and (ib-ordered? 1tag) (not (ib-ordered? 0tag)))
           (return 0tag nil))
          ;; they are both ordered, or both not
          ((ib-ordered? 0tag)
           (return nil nil))
          ;; both unordered
          ((fx> (ib-situation 0tag) (ib-situation 1tag))
           (return 0tag 1tag))
          (else
           (return 1tag 0tag)))))

;;; This should take into account whether or not the IB-NEXT slot is filled 
(define (ib-situation ib)
  (cond ((empty? (ib-jump-op ib)) 0)
        ((empty? (ib-0tag ib))  ; means block ends in unconditional jump
         (cond ((ib-free? (ib-1tag ib))
                6)    ;1 exit, free future
               ((ib-seen? (ib-1tag ib))
                7)    ;1 exit, already queued
               (else
                1)))
        (else
         (let ((1ordered? (ib-ordered? (ib-1tag ib)))
               (0ordered? (ib-ordered? (ib-0tag ib))))
           (cond ((and (not 1ordered?) (not 0ordered?))
                  3)  
                 ((and 1ordered? 0ordered?)
                  2)   
                 ((or (ib-seen? (ib-0tag ib)) (ib-seen? (ib-1tag ib)))
                  5)
                 (else
                  4))))))