;==============================================================================
;		       Copyright (C) 1992 by Marc Feeley -- all rights reserved

; file: "pvm.scm"

;------------------------------------------------------------------------------
;
; Virtual machine abstraction package:
; -----------------------------------

; (See file 'doc/pvm' for details on the virtual machine)

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Virtual machine operands:
; ------------------------
;
; Operands are represented with small integers.  Operands can thus be tested
; for equality using 'eqv?'.  'eqv-opnd?' also tests for equal operands but
; it disregards the '?' flag.  The encoding is as follows:
;
; OPERAND      ENCODING         
;
; reg(n)       0     + n
; stk(n)       10000 + n
; lbl(n)       20000 + n
; glo(name)    30000 + index in operand table
; clo(opnd,n)  40000 + index in operand table
; obj(x)       50000 + index in operand table
; ?loc         60000 + encoding(loc)

; Utilities:
; ---------

(define *opnd-table* '())
(define *opnd-table-alloc* '())

(define opnd-table-size 10000)

(define (enter-opnd arg1 arg2)
  (let loop ((i 0))
    (if (< i *opnd-table-alloc*)
      (let ((x (vector-ref *opnd-table* i)))
        (if (and (eqv? (car x) arg1) (eqv? (cdr x) arg2))
          i
          (loop (+ i 1))))
      (if (< *opnd-table-alloc* opnd-table-size)
        (begin
          (set! *opnd-table-alloc* (+ *opnd-table-alloc* 1))
          (vector-set! *opnd-table* i (cons arg1 arg2))
          i)
        (compiler-limitation-error
          "program is too long [virtual machine operand table overflow]")))))

(define (eqv-opnd? opnd1 opnd2)
  (eqv? (strip-pot-fut opnd1) (strip-pot-fut opnd2)))

(define (contains-opnd? opnd1 opnd2) ; does opnd2 contain opnd1?
  (cond ((eqv-opnd? opnd1 opnd2)
         #t)
        ((clo? opnd2)
         (contains-opnd? opnd1 (clo-base opnd2)))
        (else
         #f)))

(define (any-contains-opnd? opnd opnds)
  (if (null? opnds)
    #f
    (or (contains-opnd? opnd (car opnds))
        (any-contains-opnd? opnd (cdr opnds)))))

; Locations:
; ---------

; -- location is a register (first is number 0)
(define (make-reg num) num)
(define (reg? x) (< (modulo x 60000) 10000))
(define (reg-num x) (modulo x 10000))

; -- location is in the stack (first slot in procedure's frame is number 1)
(define (make-stk num) (+ num 10000))
(define (stk? x) (= (quotient (modulo x 60000) 10000) 1))
(define (stk-num x) (modulo x 10000))

; -- location is a global variable
(define (make-glo name) (+ (enter-opnd name #t) 30000))
(define (glo? x) (= (quotient (modulo x 60000) 10000) 3))
(define (glo-name x) (car (vector-ref *opnd-table* (modulo x 10000))))

; -- location is a closed variable (base is ptr to closure env, index >= 1)
(define (make-clo base index) (+ (enter-opnd base index) 40000))
(define (clo? x) (= (quotient (modulo x 60000) 10000) 4))
(define (clo-base x) (car (vector-ref *opnd-table* (modulo x 10000))))
(define (clo-index x) (cdr (vector-ref *opnd-table* (modulo x 10000))))

; Values:
; ------

; -- value is the address of a local label
(define (make-lbl num) (+ num 20000))
(define (lbl? x) (= (quotient (modulo x 60000) 10000) 2))
(define (lbl-num x) (modulo x 10000))
(define label-limit 9999) ; largest label

; -- value is a scheme object
(define (make-obj val) (+ (enter-opnd val #f) 50000))                    
(define (obj? x) (= (quotient (modulo x 60000) 10000) 5))         
(define (obj-val x) (car (vector-ref *opnd-table* (modulo x 10000))))

; Potentially future flag: (operands that should be touched to get their value)
; -----------------------

(define (put-pot-fut loc) (+ loc 60000))
(define (pot-fut? x) (>= x 60000))
(define (strip-pot-fut x) (modulo x 60000))
(define (set-pot-fut loc flag) (if flag (put-pot-fut loc) loc))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Processor context descriptions:
; ------------------------------

(define (make-pcontext fs map)
  (vector fs map))

(define (pcontext-fs  x) (vector-ref x 0))
(define (pcontext-map x) (vector-ref x 1))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Frame description:
; -----------------

(define (make-frame size slots regs closed live)
  (vector size slots regs closed live))

(define (frame-size x)   (vector-ref x 0))
(define (frame-slots x)  (vector-ref x 1))
(define (frame-regs x)   (vector-ref x 2))
(define (frame-closed x) (vector-ref x 3))
(define (frame-live x)   (vector-ref x 4))

(define (frame-eq? x y)
  (= (frame-size x) (frame-size y)))

(define (frame-truncate frame nb-slots)
  (let ((fs (frame-size frame)))
    (make-frame nb-slots
                (nth-after (frame-slots frame) (- fs nb-slots))
                (frame-regs frame)
                (frame-closed frame)
                (frame-live frame))))

(define (frame-live? var frame)
  (let ((live (frame-live frame)))
    (if (eq? var closure-env-var)
      (let ((closed (frame-closed frame)))
        (if (or (set-member? var live)
                (not (set-empty? (set-intersection live (list->set closed)))))
          closed
          #f))
      (if (set-member? var live)
        var
        #f))))

(define (frame-first-empty-slot frame)
  (let loop ((i 1) (s (reverse (frame-slots frame))))
    (if (pair? s)
      (if (frame-live? (car s) frame)
        (loop (+ i 1) (cdr s))
        i)
      i)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Procedure objects:
; -----------------

(define (make-proc-obj
          name
          primitive?
          code
          call-pat
          side-effects?
          strict-pat
          type)
  (let ((proc-obj
          (vector
            proc-obj-tag
            name
            primitive?
            code
            call-pat
            #f ; test
            #f ; inlinable
            #f ; specialize
            side-effects?
            strict-pat
            type)))
    (proc-obj-specialize-set! proc-obj (lambda (decls) proc-obj))
    proc-obj))

(define proc-obj-tag (list 'PROC-OBJ))

(define (proc-obj? x)
  (and (vector? x)
       (> (vector-length x) 0)
       (eq? (vector-ref x 0) proc-obj-tag)))

(define (proc-obj-name obj)                (vector-ref obj 1))
(define (proc-obj-primitive? obj)          (vector-ref obj 2))
(define (proc-obj-code obj)                (vector-ref obj 3))
(define (proc-obj-call-pat obj)            (vector-ref obj 4))
(define (proc-obj-test obj)                (vector-ref obj 5))
(define (proc-obj-inlinable obj)           (vector-ref obj 6))
(define (proc-obj-specialize obj)          (vector-ref obj 7))
(define (proc-obj-side-effects? obj)       (vector-ref obj 8))
(define (proc-obj-strict-pat obj)          (vector-ref obj 9))
(define (proc-obj-type obj)                (vector-ref obj 10))

(define (proc-obj-code-set! obj x)         (vector-set! obj 3 x))
(define (proc-obj-test-set! obj x)         (vector-set! obj 5 x))
(define (proc-obj-inlinable-set! obj x)    (vector-set! obj 6 x))
(define (proc-obj-specialize-set! obj x)   (vector-set! obj 7 x))

(define (make-pattern min-args nb-parms rest?)
  (let loop ((x (if rest? (- nb-parms 1) (list nb-parms)))
             (y (if rest? (- nb-parms 1) nb-parms)))
    (let ((z (- y 1)))
      (if (< z min-args) x (loop (cons z x) z)))))

(define (pattern-member? n pat) ; tests if 'n' is a member of pattern 'pat'
  (cond ((pair? pat)
         (if (= (car pat) n) #t (pattern-member? n (cdr pat))))
        ((null? pat)
         #f)
        (else
         (<= pat n))))

(define (type-name type)
  (if (pair? type) (car type) type))

(define (type-pot-fut? type)
  (pair? type))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Basic block set manipulation:
; ----------------------------

; Virtual instructions have a linear structure.  However, this is not how
; they are put together to form a piece of code.  Rather, virtual instructions
; are grouped into 'basic blocks' which are 'linked' together.  A basic block
; is a LABEL instruction followed by a sequence of non-branching instructions
; (i.e. APPLY, COPY or MAKE_CLOSURES) terminated by a single branch
; instruction (i.e. COND or JUMP).  Links between basic
; blocks are denoted using label references.  When a basic block ends with a
; COND instruction, the block is linked to the two basic blocks corresponding
; to the two possible control paths out of the COND instruction.  When a basic
; block ends with a JUMP instruction, there is either zero or one link.
;
; Basic blocks naturally group together to form 'basic block sets'.  A basic
; block set describes all the code of a procedure.

(define (make-bbs)

  (define (limit-error)
    (compiler-limitation-error "procedure is too long [too many labels]"))

  (vector (make-counter label-limit limit-error) ; 0 - local label counter
          (queue-empty)                          ; 1 - basic block queue
          '()))                                  ; 2 - entry label number

(define (bbs-lbl-counter bbs)                (vector-ref bbs 0))
(define (bbs-bb-queue bbs)                   (vector-ref bbs 1))
(define (bbs-bb-queue-set! bbs bbq)          (vector-set! bbs 1 bbq))
(define (bbs-entry-lbl-num bbs)              (vector-ref bbs 2))
(define (bbs-entry-lbl-num-set! bbs lbl-num) (vector-set! bbs 2 lbl-num))

(define (bbs-new-lbl! bbs)
  ((bbs-lbl-counter bbs)))

(define (lbl-num->bb lbl-num bbs)
  (let loop ((bb-list (queue->list (bbs-bb-queue bbs))))
    (if (= (bb-lbl-num (car bb-list)) lbl-num)
      (car bb-list)
      (loop (cdr bb-list)))))

; Basic block manipulation procedures:

(define (make-bb label-instr bbs)
  (let ((bb (vector
              label-instr   ; 0 - LABEL instr
              (queue-empty) ; 1 - sequence of non-branching instrs
              '()           ; 2 - branch instruction
              '()           ; 3 - basic blocks referenced by this block
              '())))        ; 4 - basic blocks which jump to this block
                            ;     (both filled in by 'bbs-purify!')
    (queue-put! (vector-ref bbs 1) bb)
    bb))

(define (bb-lbl-num bb)                  (LABEL-lbl-num (vector-ref bb 0)))
(define (bb-label-type bb)               (LABEL-type (vector-ref bb 0)))
(define (bb-label-instr bb)              (vector-ref bb 0))
(define (bb-label-instr-set! bb l)       (vector-set! bb 0 l))
(define (bb-non-branch-instrs bb)        (queue->list (vector-ref bb 1)))
(define (bb-non-branch-instrs-set! bb l) (vector-set! bb 1 (list->queue l)))
(define (bb-branch-instr bb)             (vector-ref bb 2))
(define (bb-branch-instr-set! bb b)      (vector-set! bb 2 b))
(define (bb-references bb)               (vector-ref bb 3))
(define (bb-references-set! bb l)        (vector-set! bb 3 l))
(define (bb-precedents bb)               (vector-ref bb 4))
(define (bb-precedents-set! bb l)        (vector-set! bb 4 l))

(define (bb-entry-frame-size bb)
  (frame-size (pvm-instr-frame (bb-label-instr bb))))

(define (bb-exit-frame-size bb)
  (frame-size (pvm-instr-frame (bb-branch-instr bb))))

(define (bb-slots-gained bb)
  (- (bb-exit-frame-size bb) (bb-entry-frame-size bb)))

(define (bb-put-non-branch! bb pvm-instr)
  (queue-put! (vector-ref bb 1) pvm-instr))

(define (bb-put-branch! bb pvm-instr)
  (vector-set! bb 2 pvm-instr))

(define (bb-add-reference! bb ref)
  (if (not (memq ref (vector-ref bb 3)))
    (vector-set! bb 3 (cons ref (vector-ref bb 3)))))

(define (bb-add-precedent! bb prec)
  (if (not (memq prec (vector-ref bb 4)))
    (vector-set! bb 4 (cons prec (vector-ref bb 4)))))

; Virtual machine instruction representation:

(define (pvm-instr-type pvm-instr)    (vector-ref pvm-instr 0))
(define (pvm-instr-frame pvm-instr)   (vector-ref pvm-instr 1))
(define (pvm-instr-comment pvm-instr) (vector-ref pvm-instr 2))

(define (make-LABEL-SIMP lbl-num frame comment)
  (vector 'LABEL frame comment lbl-num 'SIMP))

(define (make-LABEL-TASK lbl-num method frame comment)
  (vector 'LABEL frame comment lbl-num 'TASK method))

(define (make-LABEL-PROC lbl-num nb-parms min rest? closed? frame comment)
  (vector 'LABEL frame comment lbl-num 'PROC nb-parms min rest? closed?))

(define (make-LABEL-RETURN lbl-num task-method frame comment)
  (vector 'LABEL frame comment lbl-num 'RETURN task-method))

(define (LABEL-lbl-num pvm-instr)            (vector-ref pvm-instr 3))
(define (LABEL-type pvm-instr)               (vector-ref pvm-instr 4))

(define (LABEL-TASK-method pvm-instr)        (vector-ref pvm-instr 5))

(define (LABEL-PROC-nb-parms pvm-instr)      (vector-ref pvm-instr 5))
(define (LABEL-PROC-min pvm-instr)           (vector-ref pvm-instr 6))
(define (LABEL-PROC-rest? pvm-instr)         (vector-ref pvm-instr 7))
(define (LABEL-PROC-closed? pvm-instr)       (vector-ref pvm-instr 8))

(define (LABEL-RETURN-task-method pvm-instr) (vector-ref pvm-instr 5))

(define (make-APPLY prim opnds loc frame comment)
  (vector 'APPLY frame comment prim opnds loc))
(define (APPLY-prim pvm-instr)  (vector-ref pvm-instr 3))
(define (APPLY-opnds pvm-instr) (vector-ref pvm-instr 4))
(define (APPLY-loc pvm-instr)   (vector-ref pvm-instr 5))

(define (make-COPY opnd loc frame comment)
  (vector 'COPY frame comment opnd loc))

(define (COPY-opnd pvm-instr) (vector-ref pvm-instr 3))
(define (COPY-loc pvm-instr)  (vector-ref pvm-instr 4))

(define (make-MAKE_CLOSURES parms frame comment)
  (vector 'MAKE_CLOSURES frame comment parms))
(define (MAKE_CLOSURES-parms pvm-instr) (vector-ref pvm-instr 3))

(define (make-closure-parms loc lbl opnds)
  (vector loc lbl opnds))
(define (closure-parms-loc x)   (vector-ref x 0))
(define (closure-parms-lbl x)   (vector-ref x 1))
(define (closure-parms-opnds x) (vector-ref x 2))

(define (make-COND test opnds true false intr-check? frame comment)
  (vector 'COND frame comment test opnds true false intr-check?))
(define (COND-test pvm-instr)        (vector-ref pvm-instr 3))
(define (COND-opnds pvm-instr)       (vector-ref pvm-instr 4))
(define (COND-true pvm-instr)        (vector-ref pvm-instr 5))
(define (COND-false pvm-instr)       (vector-ref pvm-instr 6))
(define (COND-intr-check? pvm-instr) (vector-ref pvm-instr 7))

(define (make-JUMP opnd nb-args intr-check? frame comment)
  (vector 'JUMP frame comment opnd nb-args intr-check?))
(define (JUMP-opnd pvm-instr)         (vector-ref pvm-instr 3))
(define (JUMP-nb-args pvm-instr)      (vector-ref pvm-instr 4))
(define (JUMP-intr-check? pvm-instr)  (vector-ref pvm-instr 5))
(define (first-class-JUMP? pvm-instr) (JUMP-nb-args pvm-instr))

(define (make-comment)
  (cons 'COMMENT '()))

(define (comment-put! comment name val)
  (set-cdr! comment (cons (cons name val) (cdr comment))))

(define (comment-get comment name)
  (and comment
       (let ((x (assq name (cdr comment))))
         (if x (cdr x) #f))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; 'Purification' of basic block sets:
; ----------------------------------

; This step removes unreachable basic blocks (i.e. dead code), duplicate
; basic blocks (i.e. common code) and jump cascades from a basic block set.
; It also orders the basic blocks so that the destination of a branch is put
; (if possible) right after the branch instruction.  The 'references' and
; 'precedents' fields of each basic block are also filled in through the
; process.  The first basic block of a 'purified' basic block set is always
; the entry point.

(define (bbs-purify! bbs)
  (let loop () ; iterate until no more code to remove
    (bbs-remove-jump-cascades! bbs)
    (bbs-remove-dead-code! bbs)
    (if pvm-opts?
      (if (bbs-remove-common-code! bbs) (loop) (bbs-order! bbs))
      (bbs-bb-queue-set! bbs
        (list->queue
          (sort-list (queue->list (bbs-bb-queue bbs))
                     (lambda (x y) (< (bb-lbl-num x) (bb-lbl-num y)))))))))

(define pvm-opts? #f)
(set! pvm-opts? #t)

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Step 1, Jump cascade removal:

(define (bbs-remove-jump-cascades! bbs)

  (define (empty-bb? bb)
    (and (eq? (bb-label-type bb) 'SIMP)       ; simple label and
         (null? (bb-non-branch-instrs bb))))  ; no non-branching instrs

  (define (jump-lbl? branch)
    (let ((opnd (JUMP-opnd branch)))
      (if (lbl? opnd) (lbl-num opnd) #f)))

  (define (jump-to-non-entry-lbl? branch)
    (and (eq? (pvm-instr-type branch) 'JUMP)
         (not (first-class-JUMP? branch)) ; not a jump to an entry label
         (jump-lbl? branch)))

  (define (jump-cascade-to lbl-num fs intr-check? seen thunk)
    (if (memq lbl-num seen) ; infinite loop?
      (thunk lbl-num fs)
      (let ((bb (lbl-num->bb lbl-num bbs)))
        (if (and (empty-bb? bb) (<= (bb-slots-gained bb) 0))
          (let ((jump-lbl-num
                 (jump-to-non-entry-lbl? (bb-branch-instr bb))))
            (if jump-lbl-num
              (jump-cascade-to
                jump-lbl-num
                (+ fs (bb-slots-gained bb))
                (or intr-check? (JUMP-intr-check? (bb-branch-instr bb)))
                (cons lbl-num seen)
                thunk)
              (thunk lbl-num fs intr-check?)))
          (thunk lbl-num fs intr-check?)))))

  (define (equiv-lbl lbl-num seen)
    (if (memq lbl-num seen) ; infinite loop?
      lbl-num
      (let ((bb (lbl-num->bb lbl-num bbs)))
        (if (empty-bb? bb)
          (let ((jump-lbl-num
                 (jump-to-non-entry-lbl? (bb-branch-instr bb))))
            (if (and jump-lbl-num
                     (not (JUMP-intr-check? (bb-branch-instr bb)))
                     (= (bb-slots-gained bb) 0))
              (equiv-lbl jump-lbl-num (cons lbl-num seen))
              lbl-num))
          lbl-num))))

  (define (remove-cascade! bb)
    (let ((branch (bb-branch-instr bb)))

      (case (pvm-instr-type branch)

        ((COND)
         (bb-put-branch! bb  ; branch is a COND
           (make-COND (COND-test branch)
                      (COND-opnds branch)
                      (equiv-lbl (COND-true branch) '())
                      (equiv-lbl (COND-false branch) '())
                      (COND-intr-check? branch)
                      (pvm-instr-frame branch)
                      (pvm-instr-comment branch))))

        ((JUMP)  ; branch is a JUMP
         (if (not (first-class-JUMP? branch)) ; but not to an entry label
           (let ((dest-lbl-num (jump-lbl? branch)))
             (if dest-lbl-num

               (jump-cascade-to
                 dest-lbl-num
                 (frame-size (pvm-instr-frame branch))
                 (JUMP-intr-check? branch)
                 '()
                 (lambda (lbl-num fs intr-check?)
                   (let* ((dest-bb (lbl-num->bb lbl-num bbs))
                          (last-branch (bb-branch-instr dest-bb)))
                     (if (and (empty-bb? dest-bb)
                              (or (not intr-check?)
                                  put-intr-check-on-COND?
                                  (not (eq? (pvm-instr-type last-branch) 'COND))))

                       (let* ((new-fs (+ fs (bb-slots-gained dest-bb)))
                              (new-frame (frame-truncate
                                           (pvm-instr-frame branch)
                                           new-fs)))

                         (define (adjust-opnd opnd)
                           (cond ((stk? opnd)
                                  (set-pot-fut
                                    (make-stk
                                      (+ (- fs (bb-entry-frame-size dest-bb))
                                         (stk-num opnd)))
                                    (pot-fut? opnd)))
                                 ((clo? opnd)
                                  (set-pot-fut
                                    (make-clo (adjust-opnd (clo-base opnd))
                                              (clo-index opnd))
                                    (pot-fut? opnd)))
                                 (else
                                  opnd)))

                         (case (pvm-instr-type last-branch)
                           ((COND)
                            (bb-put-branch! bb
                              (make-COND (COND-test last-branch)
                                         (map adjust-opnd (COND-opnds last-branch))
                                         (equiv-lbl (COND-true last-branch) '())
                                         (equiv-lbl (COND-false last-branch) '())
                                         (or intr-check?
                                             (COND-intr-check? last-branch))
                                         new-frame
                                         (pvm-instr-comment last-branch))))
                           ((JUMP)
                            (bb-put-branch! bb
                              (make-JUMP (adjust-opnd (JUMP-opnd last-branch))
                                         (JUMP-nb-args last-branch)
                                         (or intr-check?
                                             (JUMP-intr-check? last-branch))
                                         new-frame
                                         (pvm-instr-comment last-branch))))
                           (else
                            (compiler-internal-error
                              "bbs-remove-jump-cascades!, unknown branch type"))))

                       (bb-put-branch! bb
                         (make-JUMP (make-lbl lbl-num)
                                    (JUMP-nb-args branch)
                                    (or intr-check?
                                        (JUMP-intr-check? branch))
                                    (frame-truncate
                                      (pvm-instr-frame branch)
                                      fs)
                                    (pvm-instr-comment branch)))))))))))

        (else
         (compiler-internal-error
           "bbs-remove-jump-cascades!, unknown branch type")))))

  (for-each remove-cascade!
            (queue->list (bbs-bb-queue bbs))))

(define put-intr-check-on-COND? #f)
(set! put-intr-check-on-COND? #t)

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Step 2, Dead code removal:

(define (bbs-remove-dead-code! bbs)

  (let ((new-bb-queue (queue-empty))
        (scan-queue (queue-empty)))

    (define (reachable ref bb)
      (if bb (bb-add-reference! bb ref))
      (if (not (memq ref (queue->list new-bb-queue)))
        (begin
          (bb-references-set! ref '())
          (bb-precedents-set! ref '())
          (queue-put! new-bb-queue ref)
          (queue-put! scan-queue ref))))

    (define (direct-jump to-bb from-bb)
      (reachable to-bb from-bb)
      (bb-add-precedent! to-bb from-bb))

    (define (scan-instr pvm-instr bb)

      (define (scan-opnd pvm-opnd)
        (cond ((lbl? pvm-opnd)
               (reachable (lbl-num->bb (lbl-num pvm-opnd) bbs) bb))
              ((clo? pvm-opnd)
               (scan-opnd (clo-base pvm-opnd)))))

      (case (pvm-instr-type pvm-instr)

        ((LABEL)
         '())

        ((APPLY)
         (for-each scan-opnd (APPLY-opnds pvm-instr))
         (if (APPLY-loc pvm-instr)
           (scan-opnd (APPLY-loc pvm-instr))))

        ((COPY)
         (scan-opnd (COPY-opnd pvm-instr))
         (scan-opnd (COPY-loc pvm-instr)))

        ((MAKE_CLOSURES)
         (for-each (lambda (parm)
                     (reachable (lbl-num->bb (closure-parms-lbl parm) bbs) bb)
                     (scan-opnd (closure-parms-loc parm))
                     (for-each scan-opnd (closure-parms-opnds parm)))
                   (MAKE_CLOSURES-parms pvm-instr)))

        ((COND)
         (for-each scan-opnd (COND-opnds pvm-instr))
         (direct-jump (lbl-num->bb (COND-true pvm-instr) bbs) bb)
         (direct-jump (lbl-num->bb (COND-false pvm-instr) bbs) bb))

        ((JUMP)
         (let ((opnd (JUMP-opnd pvm-instr)))
           (if (lbl? opnd)
             (direct-jump (lbl-num->bb (lbl-num opnd) bbs) bb)
             (scan-opnd (JUMP-opnd pvm-instr)))))

        (else
         (compiler-internal-error
           "bbs-remove-dead-code!, unknown PVM instruction type"))))

    (reachable (lbl-num->bb (bbs-entry-lbl-num bbs) bbs) #f)

    (let loop ()
      (if (not (queue-empty? scan-queue))
        (let ((bb (queue-get! scan-queue)))
          (begin
            (scan-instr (bb-label-instr bb) bb)
            (for-each (lambda (pvm-instr) (scan-instr pvm-instr bb))
                      (bb-non-branch-instrs bb))
            (scan-instr (bb-branch-instr bb) bb)
            (loop)))))

    (bbs-bb-queue-set! bbs new-bb-queue)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Step 3, Common code removal:

(define (bbs-remove-common-code! bbs)
  (let* ((bb-list (queue->list (bbs-bb-queue bbs)))
         (n (length bb-list))
         (hash-table-length
           (cond ((< n 50)  43) ; select reasonable size for hash table
                 ((< n 500) 403)
                 (else      4003)))
         (hash-table (make-vector hash-table-length '()))
         (prim-table '())
         (block-map '())
         (changed? #f))

  (define (hash-prim prim)
    (let ((n (length prim-table))
          (i (pos-in-list prim prim-table)))
      (if i
        (- n i)
        (begin
          (set! prim-table (cons prim prim-table))
          (+ n 1)))))

  (define (hash-opnds l) ; this assumes that operands are encoded with nbs
    (let loop ((l l) (n 0))
      (if (pair? l)
        (loop (cdr l)
              (let ((x (car l)))
                (if (lbl? x) n (modulo (+ (* n 10000) x) hash-table-length))))
        n)))

  (define (hash-bb bb) ; compute hash address for a basic block
    (let ((branch (bb-branch-instr bb)))
      (modulo
        (case (pvm-instr-type branch)
          ((COND)
           (+ (hash-opnds (COND-opnds branch))
              (* 10 (hash-prim (COND-test branch)))
              (* 100 (frame-size (pvm-instr-frame branch)))))
          ((JUMP)
           (+ (hash-opnds (list (JUMP-opnd branch)))
              (* 10 (or (JUMP-nb-args branch) -1))
              (* 100 (frame-size (pvm-instr-frame branch)))))
          (else
           0))
        hash-table-length)))

  (define (replacement-lbl-num lbl)
    (let ((x (assv lbl block-map)))
      (if x (cdr x) lbl)))

  (define (fix-map! bb1 bb2) ; bb1 should be replaced by bb2 in the block-map
    (let loop ((l block-map))
      (if (pair? l)
        (let ((x (car l)))
          (if (= bb1 (cdr x)) (set-cdr! x bb2))
          (loop (cdr l))))))

  (define (enter-bb! bb) ; enter a basic block in the hash table
    (let ((h (hash-bb bb)))
      (vector-set! hash-table h
        (add-bb bb (vector-ref hash-table h)))))

  (define (add-bb bb l) ; add basic block 'bb' to list of basic blocks
    (if (pair? l)
      (let ((bb* (car l))) ; pick next basic block in list

        (set! block-map ; for now, assume that 'bb' = 'bb*'
          (cons (cons (bb-lbl-num bb) (bb-lbl-num bb*))
                block-map))

        (if (eqv-bb? bb bb*) ; are they the same?

          (begin
            (fix-map! (bb-lbl-num bb) (bb-lbl-num bb*)) ; record the equivalence
            (set! changed? #t)
            l)

          (begin
            (set! block-map (cdr block-map)) ; they are not the same!
            (if (eqv-pvm-instr? (bb-branch-instr bb) (bb-branch-instr bb*))

              (extract-common-tail bb bb* ; check if tail is the same
                (lambda (head head* tail)
                  (if (null? tail) ; common tail long enough?

                    (cons bb* (add-bb bb (cdr l))) ; no, so try rest of list

                    (let* ((lbl (bbs-new-lbl! bbs)) ; create bb for common tail
                           (branch (bb-branch-instr bb))
                           (fs** (need-pvm-instrs tail branch))
                           (frame (frame-truncate
                                    (pvm-instr-frame
                                      (if (null? head)
                                        (bb-label-instr bb)
                                        (car head)))
                                    fs**))
                           (bb** (make-bb (make-LABEL-SIMP lbl frame #f) bbs)))
                      (bb-non-branch-instrs-set! bb** tail)
                      (bb-branch-instr-set! bb** branch)
                      (bb-non-branch-instrs-set! bb* (reverse head*))
                      (bb-branch-instr-set! bb*
                        (make-JUMP (make-lbl lbl) #f #f frame #f))
                      (bb-non-branch-instrs-set! bb (reverse head))
                      (bb-branch-instr-set! bb
                        (make-JUMP (make-lbl lbl) #f #f frame #f))
                      (set! changed? #t)
                      (cons bb (cons bb* (add-bb bb** (cdr l))))))))

                (cons bb* (add-bb bb (cdr l)))))))

        (list bb)))

  (define (extract-common-tail bb1 bb2 cont)
    (let loop ((l1 (reverse (bb-non-branch-instrs bb1)))
               (l2 (reverse (bb-non-branch-instrs bb2)))
               (tail '()))
      (if (and (pair? l1) (pair? l2))
        (let ((i1 (car l1))
              (i2 (car l2)))
          (if (eqv-pvm-instr? i1 i2)
            (loop (cdr l1) (cdr l2) (cons i1 tail))
            (cont l1 l2 tail)))
        (cont l1 l2 tail))))

  (define (eqv-bb? bb1 bb2)
    (let ((bb1-non-branch (bb-non-branch-instrs bb1))
          (bb2-non-branch (bb-non-branch-instrs bb2)))
      (and (= (length bb1-non-branch) (length bb2-non-branch))
           (eqv-pvm-instr? (bb-label-instr bb1) (bb-label-instr bb2))
           (eqv-pvm-instr? (bb-branch-instr bb1) (bb-branch-instr bb2))
           (eqv-list? eqv-pvm-instr? bb1-non-branch bb2-non-branch))))

  (define (eqv-list? pred? l1 l2)
    (if (pair? l1)
      (and (pair? l2)
           (pred? (car l1) (car l2))
           (eqv-list? pred? (cdr l1) (cdr l2)))
      (not (pair? l2))))

  (define (eqv-lbl-num? lbl1 lbl2)
    (= (replacement-lbl-num lbl1)
       (replacement-lbl-num lbl2)))

  (define (eqv-pvm-opnd? opnd1 opnd2)
    (if (not opnd1)
      (not opnd2)
      (and opnd2
           (eq? (pot-fut? opnd1) (pot-fut? opnd2))
           (cond ((lbl? opnd1)
                  (and (lbl? opnd2)
                       (eqv-lbl-num? (lbl-num opnd1) (lbl-num opnd2))))
                 ((clo? opnd1)
                  (and (clo? opnd2)
                       (= (clo-index opnd1) (clo-index opnd2))
                       (eqv-pvm-opnd? (clo-base opnd1)
                                      (clo-base opnd2))))
                 (else
                  (eqv? opnd1 opnd2))))))
    
  (define (eqv-pvm-instr? instr1 instr2)

    (define (eqv-closure-parms? p1 p2)
      (and (eqv-pvm-opnd? (closure-parms-loc p1)
                          (closure-parms-loc p2))
           (eqv-lbl-num? (closure-parms-lbl p1)
                         (closure-parms-lbl p2))
           (eqv-list? eqv-pvm-opnd?
                      (closure-parms-opnds p1)
                      (closure-parms-opnds p2))))

    (let ((type1 (pvm-instr-type instr1))
          (type2 (pvm-instr-type instr2)))
      (and (eq? type1 type2)
           (frame-eq? (pvm-instr-frame instr1) (pvm-instr-frame instr2))
           (case type1

             ((LABEL)
              (let ((ltype1 (LABEL-type instr1))
                    (ltype2 (LABEL-type instr2)))
                (and (eq? ltype1 ltype2)
                     (case ltype1
                       ((SIMP)
                        #t)
                       ((TASK)
                        (eq? (LABEL-TASK-method instr1)
                             (LABEL-TASK-method instr2)))
                       ((RETURN)
                        (eq? (LABEL-RETURN-task-method instr1)
                             (LABEL-RETURN-task-method instr2)))
                       ((PROC)
                        (and (= (LABEL-PROC-min instr1)
                                (LABEL-PROC-min instr2))
                             (= (LABEL-PROC-nb-parms instr1)
                                (LABEL-PROC-nb-parms instr2))
                             (eq? (LABEL-PROC-rest? instr1)
                                  (LABEL-PROC-rest? instr2))
                             (eq? (LABEL-PROC-closed? instr1)
                                  (LABEL-PROC-closed? instr2))))
                       (else
                        (compiler-internal-error
                          "eqv-pvm-instr?, unknown label type"))))))

             ((APPLY)
              (and (eq? (APPLY-prim instr1) (APPLY-prim instr2))
                   (eqv-list? eqv-pvm-opnd?
                              (APPLY-opnds instr1)
                              (APPLY-opnds instr2))
                   (eqv-pvm-opnd? (APPLY-loc instr1)
                                  (APPLY-loc instr2))))

             ((COPY)
              (and (eqv-pvm-opnd? (COPY-opnd instr1)
                                  (COPY-opnd instr2))
                   (eqv-pvm-opnd? (COPY-loc instr1)
                                  (COPY-loc instr2))))

             ((MAKE_CLOSURES)
              (eqv-list? eqv-closure-parms?
                         (MAKE_CLOSURES-parms instr1)
                         (MAKE_CLOSURES-parms instr2)))

             ((COND)
              (and (eq? (COND-test instr1)
                        (COND-test instr2))
                   (eqv-list? eqv-pvm-opnd?
                              (COND-opnds instr1)
                              (COND-opnds instr2))
                   (eqv-lbl-num? (COND-true instr1)
                                 (COND-true instr2))
                   (eqv-lbl-num? (COND-false instr1)
                                 (COND-false instr2))
                   (eq? (COND-intr-check? instr1)
                        (COND-intr-check? instr2))))

             ((JUMP)
              (and (eqv-pvm-opnd? (JUMP-opnd instr1)
                                  (JUMP-opnd instr2))
                   (eqv? (JUMP-nb-args instr1)
                         (JUMP-nb-args instr2))
                   (eq? (JUMP-intr-check? instr1)
                        (JUMP-intr-check? instr2))))

             (else
              (compiler-internal-error
                "eqv-pvm-instr?, unknown 'pvm-instr':" instr1))))))

  (define (update-pvm-opnd opnd)
    (if opnd
      (cond ((lbl? opnd)
             (set-pot-fut
               (make-lbl (replacement-lbl-num (lbl-num opnd)))
               (pot-fut? opnd)))
            ((clo? opnd)
             (set-pot-fut
               (make-clo (update-pvm-opnd (clo-base opnd)) (clo-index opnd))
               (pot-fut? opnd)))
            (else
             opnd))
      opnd))

  (define (update-pvm-instr instr)

    (define (update-closure-parms p)
      (make-closure-parms
        (update-pvm-opnd (closure-parms-loc p))
        (replacement-lbl-num (closure-parms-lbl p))
        (map update-pvm-opnd (closure-parms-opnds p))))

    (case (pvm-instr-type instr)

      ((LABEL)
       (case (LABEL-type instr)
         ((SIMP)
          (make-LABEL-SIMP (LABEL-lbl-num instr)
                           (pvm-instr-frame instr)
                           (pvm-instr-comment instr)))
         ((TASK)
          (make-LABEL-TASK (LABEL-lbl-num instr)
                           (LABEL-TASK-method instr)
                           (pvm-instr-frame instr)
                           (pvm-instr-comment instr)))
         ((PROC)
          (make-LABEL-PROC (LABEL-lbl-num instr)
                           (LABEL-PROC-nb-parms instr)
                           (LABEL-PROC-min instr)
                           (LABEL-PROC-rest? instr)
                           (LABEL-PROC-closed? instr)
                           (pvm-instr-frame instr)
                           (pvm-instr-comment instr)))
         ((RETURN)
          (make-LABEL-RETURN (LABEL-lbl-num instr)
                             (LABEL-RETURN-task-method instr)
                             (pvm-instr-frame instr)
                             (pvm-instr-comment instr)))
         (else
          (compiler-internal-error
            "update-pvm-instr, unknown label type"))))

      ((APPLY)
       (make-APPLY (APPLY-prim instr)
                   (map update-pvm-opnd (APPLY-opnds instr))
                   (update-pvm-opnd (APPLY-loc instr))
                   (pvm-instr-frame instr)
                   (pvm-instr-comment instr)))

      ((COPY)
       (make-COPY (update-pvm-opnd (COPY-opnd instr))
                  (update-pvm-opnd (COPY-loc instr))
                  (pvm-instr-frame instr)
                  (pvm-instr-comment instr)))

      ((MAKE_CLOSURES)
       (make-MAKE_CLOSURES
         (map update-closure-parms (MAKE_CLOSURES-parms instr))
         (pvm-instr-frame instr)
         (pvm-instr-comment instr)))

      ((COND)
       (make-COND (COND-test instr)
                  (map update-pvm-opnd (COND-opnds instr))
                  (replacement-lbl-num (COND-true instr))
                  (replacement-lbl-num (COND-false instr))
                  (COND-intr-check? instr)
                  (pvm-instr-frame instr)
                  (pvm-instr-comment instr)))

      ((JUMP)
       (make-JUMP (update-pvm-opnd (JUMP-opnd instr))
                  (JUMP-nb-args instr)
                  (JUMP-intr-check? instr)
                  (pvm-instr-frame instr)
                  (pvm-instr-comment instr)))

      (else
       (compiler-internal-error
         "update-pvm-instr, unknown 'instr':" instr))))

  (define (update-bb! bb)
    (bb-label-instr-set! bb
      (update-pvm-instr (bb-label-instr bb)))
    (bb-non-branch-instrs-set! bb
      (map update-pvm-instr (bb-non-branch-instrs bb)))
    (bb-branch-instr-set! bb
      (update-pvm-instr (bb-branch-instr bb))))

  ; Fill hash table, remove equivalent basic blocks and common tails

  (for-each enter-bb! bb-list)

  ; Reconstruct bbs

  (bbs-entry-lbl-num-set! bbs
    (replacement-lbl-num (bbs-entry-lbl-num bbs)))

  (let loop ((i 0) (result '()))
    (if (< i hash-table-length)
      (let ((bb-kept (vector-ref hash-table i)))
        (for-each update-bb! bb-kept)
        (loop (+ i 1) (append bb-kept result)))
      (bbs-bb-queue-set! bbs (list->queue result))))

  changed?))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Step 4, Basic block set ordering:

(define (bbs-order! bbs)

  (let ((new-bb-queue (queue-empty))
        (left-to-schedule (queue->list (bbs-bb-queue bbs))))

    (define (remove x l)
      (if (eq? (car l) x)
        (cdr l)
        (cons (car l) (remove x (cdr l)))))

    ; update list of basic blocks not yet scheduled

    (define (remove-bb! bb)
      (set! left-to-schedule (remove bb left-to-schedule))
      bb)

    ; return a basic block which ends with a branch to 'bb' (and that is
    ; still in 'left-to-schedule') or #f if there aren't any

    (define (prec-bb bb)
      (let loop ((l (bb-precedents bb)) (best #f) (best-fs #f))
        (if (null? l)
          best
          (let* ((x (car l))
                 (x-fs (bb-exit-frame-size x)))
            (if (and (memq x left-to-schedule)
                     (or (not best) (< x-fs best-fs)))
              (loop (cdr l) x x-fs)
              (loop (cdr l) best best-fs))))))

    ; return the basic block which 'bb' jumps to (and that is still in
    ; 'left-to-schedule') or #f if there aren't any

    (define (succ-bb bb)

      (define (branches-to-lbl? bb)
        (let ((branch (bb-branch-instr bb)))
          (case (pvm-instr-type branch)
            ((COND) #t)
            ((JUMP) (lbl? (JUMP-opnd branch)))
            (else
             (compiler-internal-error
              "bbs-order!, unknown branch type")))))

      (define (best-succ bb1 bb2)   ; heuristic that determines which
        (if (branches-to-lbl? bb1)  ; bb is most frequently executed
           bb1
           (if (branches-to-lbl? bb2)
             bb2
             (if (< (bb-exit-frame-size bb1)
                    (bb-exit-frame-size bb2))
               bb2
               bb1))))

      (let ((branch (bb-branch-instr bb)))
        (case (pvm-instr-type branch)
          ((COND)
           (let* ((true-bb (lbl-num->bb (COND-true branch) bbs))
                  (true-bb* (and (memq true-bb left-to-schedule)
                                 true-bb))
                  (false-bb (lbl-num->bb (COND-false branch) bbs))
                  (false-bb* (and (memq false-bb left-to-schedule)
                                  false-bb)))
             (if (and true-bb* false-bb*)
               (best-succ true-bb* false-bb*)
               (or true-bb* false-bb*))))
          ((JUMP)
           (let ((opnd (JUMP-opnd branch)))
             (and (lbl? opnd)
                  (let ((bb (lbl-num->bb (lbl-num opnd) bbs)))
                    (and (memq bb left-to-schedule) bb)))))
          (else
           (compiler-internal-error
             "bbs-order!, unknown branch type")))))

    ; schedule a given basic block 'bb' with it's predecessors and
    ; successors.

    (define (schedule-from bb)
      (queue-put! new-bb-queue bb)
      (let ((x (succ-bb bb)))
        (if x
          (begin
            (schedule-around (remove-bb! x))
            (let ((y (succ-bb bb)))
              (if y
                (schedule-around (remove-bb! y)))))))
      (schedule-refs bb))

    (define (schedule-around bb)
      (let ((x (prec-bb bb)))
        (if x
          (let ((bb-list (schedule-back (remove-bb! x) '())))
            (queue-put! new-bb-queue x)
            (schedule-forw bb)
            (for-each schedule-refs bb-list))
          (schedule-from bb))))

    (define (schedule-back bb bb-list)
      (let ((bb-list* (cons bb bb-list))
            (x (prec-bb bb)))
        (if x
          (let ((bb-list (schedule-back (remove-bb! x) bb-list*)))
            (queue-put! new-bb-queue x)
            bb-list)
          bb-list*)))

    (define (schedule-forw bb)
      (queue-put! new-bb-queue bb)
      (let ((x (succ-bb bb)))
        (if x
          (begin
            (schedule-forw (remove-bb! x))
            (let ((y (succ-bb bb)))
              (if y
                (schedule-around (remove-bb! y)))))))
      (schedule-refs bb))

    (define (schedule-refs bb)
      (for-each
        (lambda (x)
          (if (memq x left-to-schedule) (schedule-around (remove-bb! x))))
        (bb-references bb)))

    (schedule-from (remove-bb! (lbl-num->bb (bbs-entry-lbl-num bbs) bbs)))

    (bbs-bb-queue-set! bbs new-bb-queue)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Sequentialization of a basic block set:
; --------------------------------------

; The procedure 'bbs->code-list' transforms a 'purified' basic block set
; into a sequence of virtual machine instructions.  Each element of the
; resulting list is a 'code' object that contains a PVM instruction,
; a pointer to the basic block it came from and a `slots needed' index
; that specifies the minimum number of slots that have to be kept (relative
; to the start of the frame) after the instruction is executed.
; The procedure does a few optimizations: fall-through JUMP removal and
; deletion of unnecessary LABELs.  The first element of the code list is the
; entry label for the piece of code.

(define (make-code bb pvm-instr sn)     (vector bb pvm-instr sn))
(define (code-bb code)                  (vector-ref code 0))
(define (code-pvm-instr code)           (vector-ref code 1))
(define (code-slots-needed code)        (vector-ref code 2))
(define (code-slots-needed-set! code n) (vector-set! code 2 n))

(define (bbs->code-list bbs)
  (let ((code-list (linearize bbs)))
    (setup-slots-needed! code-list)
    code-list))

(define (linearize bbs) ; turn bbs into list and remove LABELs & JUMPs

  (let ((code-queue (queue-empty)))

    (define (put-bb prec-bb pres-bb next-bb label-needed?)

      (define (put-instr pvm-instr)
        (queue-put! code-queue (make-code pres-bb pvm-instr #f)))

      (if label-needed?
        (put-instr (bb-label-instr pres-bb))) ; put label only if truly needed

      (for-each put-instr (bb-non-branch-instrs pres-bb)) ; put non-branching instrs

      (let ((branch (bb-branch-instr pres-bb)))
        (case (pvm-instr-type branch)
          ((COND)
           (put-instr branch)
           #t)

          ((JUMP)
           (let ((opnd (JUMP-opnd branch)))
             (if (or (not next-bb) ; remove JUMP if it falls through?
                     (not (lbl? opnd))
                     (not (= (lbl-num opnd) (bb-lbl-num next-bb)))
                     (not (= (length (bb-precedents next-bb)) 1))
                     (not (eq? (bb-label-type next-bb) 'SIMP)) ; not a simple label
                     (not (= (frame-size (pvm-instr-frame branch))
                             (bb-entry-frame-size next-bb)))
                     (JUMP-intr-check? branch))
               (begin (put-instr branch) #t)
               #f)))

          (else
           (compiler-internal-error
             "linearize, unknown branch type")))))

    (let loop ((l (queue->list (bbs-bb-queue bbs)))
               (prev-bb #f)
               (label-needed? #t))
      (if (not (null? l))
        (let ((pres-bb (car l)))
          (loop (cdr l)
                pres-bb
                (put-bb prev-bb
                        pres-bb
                        (if (null? (cdr l)) #f (cadr l))
                        label-needed?)))))

    (queue->list code-queue)))

(define (setup-slots-needed! code-list) ; setup `slots-needed' field
  (if (null? code-list)
    #f
    (let* ((code (car code-list))
           (pvm-instr (code-pvm-instr code))
           (sn-rest (setup-slots-needed! (cdr code-list))))

      (case (pvm-instr-type pvm-instr)

        ((LABEL)
         (if (> sn-rest (frame-size (pvm-instr-frame pvm-instr)))
           (compiler-internal-error
             "setup-slots-needed!, incoherent slots needed for LABEL"))
         (code-slots-needed-set! code sn-rest)
         #f)

        ((COND JUMP)
         (let ((sn (frame-size (pvm-instr-frame pvm-instr))))
           (code-slots-needed-set! code sn)
           (need-pvm-instr pvm-instr sn)))
	 
        (else 
         (code-slots-needed-set! code sn-rest)
         (need-pvm-instr pvm-instr sn-rest))))))

(define (need-pvm-instrs non-branch branch)
  (if (pair? non-branch)
    (need-pvm-instr (car non-branch)
                    (need-pvm-instrs (cdr non-branch) branch))
    (need-pvm-instr branch (frame-size (pvm-instr-frame branch)))))

(define (need-pvm-instr pvm-instr sn-rest)
  (case (pvm-instr-type pvm-instr)

    ((LABEL)
     sn-rest)

    ((APPLY)
     (let ((loc (APPLY-loc pvm-instr)))
       (need-pvm-opnds (APPLY-opnds pvm-instr)
         (need-pvm-loc-opnd loc
           (need-pvm-loc loc sn-rest)))))

    ((COPY)
     (let ((loc (COPY-loc pvm-instr)))
       (need-pvm-opnd (COPY-opnd pvm-instr)
         (need-pvm-loc-opnd loc
           (need-pvm-loc loc sn-rest)))))

    ((MAKE_CLOSURES)
     (let ((parms (MAKE_CLOSURES-parms pvm-instr)))

       (define (need-parms-opnds p)
         (if (null? p)
           sn-rest
           (need-pvm-opnds (closure-parms-opnds (car p))
             (need-parms-opnds (cdr p)))))

       (define (need-parms-loc p)
         (if (null? p)
           (need-parms-opnds parms)
           (let ((loc (closure-parms-loc (car p))))
             (need-pvm-loc-opnd loc
               (need-pvm-loc loc (need-parms-loc (cdr p)))))))

       (need-parms-loc parms)))

    ((COND)
     (need-pvm-opnds (COND-opnds pvm-instr) sn-rest))

    ((JUMP)
     (need-pvm-opnd (JUMP-opnd pvm-instr) sn-rest))
	 
    (else 
     (compiler-internal-error
       "need-pvm-instr, unknown 'pvm-instr':" pvm-instr))))

(define (need-pvm-loc loc sn-rest)
  (if (and loc (stk? loc) (>= (stk-num loc) sn-rest))
    (- (stk-num loc) 1)
    sn-rest))

(define (need-pvm-loc-opnd pvm-loc slots-needed)
  (if (and pvm-loc (clo? pvm-loc))
    (need-pvm-opnd (clo-base pvm-loc) slots-needed)
    slots-needed))

(define (need-pvm-opnd pvm-opnd slots-needed)
  (cond ((stk? pvm-opnd)
         (max (stk-num pvm-opnd) slots-needed))
        ((clo? pvm-opnd)
         (need-pvm-opnd (clo-base pvm-opnd) slots-needed))
        (else
         slots-needed)))

(define (need-pvm-opnds pvm-opnds slots-needed)
  (if (null? pvm-opnds)
    slots-needed
    (need-pvm-opnd (car pvm-opnds)
                   (need-pvm-opnds (cdr pvm-opnds) slots-needed))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Basic block writing:
; -------------------

(define (write-bb bb port)
  (write-pvm-instr (bb-label-instr bb) port)
  (display " [precedents=" port)
  (write (map bb-lbl-num (bb-precedents bb)) port)
  (display "]" port)
  (newline port)

  (for-each (lambda (x) (write-pvm-instr x port) (newline port))
            (bb-non-branch-instrs bb))

  (write-pvm-instr (bb-branch-instr bb) port))

(define (write-bbs bbs port)
  (for-each (lambda (bb)
              (if (= (bb-lbl-num bb) (bbs-entry-lbl-num bbs))
                (begin (display "**** Entry block:" port) (newline port)))
              (write-bb bb port)
              (newline port))
            (queue->list (bbs-bb-queue bbs))))

(define (virtual.dump proc port)

  (let ((proc-seen (queue-empty))
        (proc-left (queue-empty)))

    (define (scan-opnd pvm-opnd)
      (cond ((obj? pvm-opnd)
             (let ((val (obj-val pvm-opnd)))
               (if (and (proc-obj? val)
                        (proc-obj-code val)
                        (not (memq val (queue->list proc-seen))))
                 (begin
                   (queue-put! proc-seen val)
                   (queue-put! proc-left val)))))
            ((clo? pvm-opnd)
             (scan-opnd (clo-base pvm-opnd)))))

    (define (dump-proc p)

      (define (scan-code code)
        (let ((pvm-instr (code-pvm-instr code))
              (slots-needed (code-slots-needed code)))
          (if (> slots-needed 9) (display "[" port) (display "[ " port))
          (display slots-needed port)
          (display "] " port)

          (write-pvm-instr pvm-instr port)
          (newline port)
          (case (pvm-instr-type pvm-instr)

            ((APPLY)
             (for-each scan-opnd (APPLY-opnds pvm-instr))
             (if (APPLY-loc pvm-instr)
               (scan-opnd (APPLY-loc pvm-instr))))

            ((COPY)
             (scan-opnd (COPY-opnd pvm-instr))
             (scan-opnd (COPY-loc pvm-instr)))

            ((MAKE_CLOSURES)
             (for-each (lambda (parms)
                         (scan-opnd (closure-parms-loc parms))
                         (for-each scan-opnd (closure-parms-opnds parms)))
                       (MAKE_CLOSURES-parms pvm-instr)))

            ((COND)
             (for-each scan-opnd (COND-opnds pvm-instr)))

            ((JUMP)
             (scan-opnd (JUMP-opnd pvm-instr)))

            (else
             '()))))

      (if (proc-obj-primitive? p)
        (display "**** #[primitive " port)
        (display "**** #[procedure " port))
      (display (proc-obj-name p) port)
      (display "] =" port)
      (newline port)

      (for-each scan-code (bbs->code-list (proc-obj-code p)))

      (newline port))
       
    (scan-opnd (make-obj proc))

    (let loop ()
      (if (not (queue-empty? proc-left))
        (begin
          (dump-proc (queue-get! proc-left))
          (loop))))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Virtual instruction writing:
; ---------------------------

(define (write-pvm-instr pvm-instr port)

  (define (write-closure-parms parms)
    (let ((len (write-pvm-opnd (closure-parms-loc parms) port)))
      (display ",L" port)
      (let ((len (+ len (+ 2 (write-returning-len
                               (closure-parms-lbl parms)
                               port)))))
        (let loop ((l (closure-parms-opnds parms)) (len len))
          (if (pair? l)
            (let ((opnd (car l)))
              (display "," port)
              (loop (cdr l) (+ len (+ (write-pvm-opnd opnd port) 1))))
            len)))))

  (define (write-upcase str)
    (let ((len (string-length str)))
      (let loop ((i 0))
        (if (< i len)
          (begin
            (write-char (char-upcase (string-ref str i)) port)
            (loop (+ i 1)))
          len))))

  (define (write-task-method method)
    (if method
      (begin
        (display "," port)
        (+ 1 (write-upcase (symbol->string method))))
      0))

  (define (write-instr pvm-instr)
    (case (pvm-instr-type pvm-instr)

      ((LABEL)
       (display "LABEL(L" port)
       (let ((len (+ 7 (write-returning-len (LABEL-lbl-num pvm-instr) port))))
         (case (LABEL-type pvm-instr)
           ((SIMP)
            (display ",SIMP)" port)
            (+ len 6))
           ((TASK)
            (display ",TASK" port)
            (let ((len (+ len
                          (+ 5
                             (write-task-method
                               (LABEL-TASK-method pvm-instr))))))
              (display ")" port)
              (+ len 1)))
           ((PROC)
            (display ",PROC," port)
            (let ((len (+ len
                          (+ 6
                             (if (not (= (LABEL-PROC-min pvm-instr)
                                         (LABEL-PROC-nb-parms pvm-instr)))
                               (let ((len (+ len
                                             (write-returning-len
                                               (LABEL-PROC-min pvm-instr)
                                               port))))
                                 (display "-" port)
                                 (+ len 1))
                               0)))))
              (let ((len (+ len
                            (write-returning-len
                              (LABEL-PROC-nb-parms pvm-instr)
                              port))))
                (let ((len (+ len
                              (if (LABEL-PROC-rest? pvm-instr)
                                (begin (display "..." port) 3)
                                0))))
                  (let ((len (+ len
                                (if (LABEL-PROC-closed? pvm-instr)
                                  (begin (display ",CLOSED" port) 7)
                                  0))))
                    (display ")" port)
                    (+ len 1))))))
           ((RETURN)
            (display ",RETURN" port)
            (let ((len (+ len
                          (+ 7
                             (write-task-method
                               (LABEL-RETURN-task-method pvm-instr))))))
              (display ")" port)
              (+ len 1)))
           (else
            (compiler-internal-error
              "write-pvm-instr, unknown label type")))))

      ((APPLY)
       (display "  APPLY(" port)
       (let ((len (+ 8 (display-returning-len
                         (proc-obj-name (APPLY-prim pvm-instr))
                         port))))
          (let loop ((l (APPLY-opnds pvm-instr)) (len len))
            (if (pair? l)
              (let ((opnd (car l)))
                (display "," port)
                (loop (cdr l) (+ len (+ (write-pvm-opnd opnd port) 1))))
              (begin
                (display "," port)
                (let ((len (+ len
                              (+ 1
                                 (if (APPLY-loc pvm-instr)
                                   (write-pvm-opnd (APPLY-loc pvm-instr) port)
                                   0)))))
                  (display ")" port)
                  (+ len 1)))))))

      ((COPY)
       (display "  COPY(" port)
       (let ((len (+ 7 (write-pvm-opnd (COPY-opnd pvm-instr) port))))
         (display "," port)
         (let ((len (+ len (+ 1 (write-pvm-opnd (COPY-loc pvm-instr) port)))))
           (display ")" port)
           (+ len 1))))

      ((MAKE_CLOSURES)
       (display "  MAKE_CLOSURES(" port)
       (let ((len (+ 16 (write-closure-parms
                          (car (MAKE_CLOSURES-parms pvm-instr))))))
         (let loop ((l (cdr (MAKE_CLOSURES-parms pvm-instr))) (len len))
           (if (pair? l)
             (let ((x (car l)))
               (display "/" port)
               (loop (cdr l) (+ len (+ (write-closure-parms x) 1))))
             (begin
               (display ")" port)
               (+ len 1))))))

      ((COND)
       (display "  COND(" port)
       (let ((len (+ 7 (display-returning-len
                         (proc-obj-name (COND-test pvm-instr))
                         port))))
         (let loop ((l (COND-opnds pvm-instr)) (len len))
           (if (pair? l)
             (let ((opnd (car l)))
               (display "," port)
               (loop (cdr l) (+ len (+ (write-pvm-opnd opnd port) 1))))
             (begin
               (display ",L" port)
               (let ((len (+ len (+ 2 (write-returning-len
                                        (COND-true pvm-instr)
                                        port)))))
                 (display ",L" port)
                 (let ((len (+ len (+ 2 (write-returning-len
                                          (COND-false pvm-instr)
                                          port)))))
                   (let ((len (+ len (if (COND-intr-check? pvm-instr)
                                       (begin (display ",INTR-CHECK" port) 11)
                                       0))))
                     (display ")" port)
                     (+ len 1)))))))))

      ((JUMP)
       (display "  JUMP(" port)
       (let ((len (+ 7 (write-pvm-opnd (JUMP-opnd pvm-instr) port))))
         (let ((len (+ len (if (JUMP-nb-args pvm-instr)
                             (begin
                               (display "," port)
                               (+ 1 (write-returning-len
                                      (JUMP-nb-args pvm-instr)
                                      port)))
                             0))))
           (let ((len (+ len (if (JUMP-intr-check? pvm-instr)
                               (begin (display ",INTR-CHECK" port) 11)
                               0))))
             (display ")" port)
             (+ len 1)))))

      (else
       (compiler-internal-error
         "write-pvm-instr, unknown 'pvm-instr':"
         pvm-instr))))

  (define (spaces n)
    (if (> n 0)
      (if (> n 7)
        (begin (display "        " port) (spaces (- n 8)))
        (begin (display " " port) (spaces (- n 1))))))

  (let ((len (write-instr pvm-instr)))
    (spaces (- 80 len))
    (display " " port)
    (write-frame (pvm-instr-frame pvm-instr) port))

  (let ((x (pvm-instr-comment pvm-instr)))
    (if x
      (let ((y (comment-get x 'TEXT)))
        (if y
          (begin
            (display " ; " port)
            (display y port)))))))

(define (write-frame frame port)

  (define (write-var var opnd sep)
    (display sep port)
    (write-pvm-opnd opnd port)
    (if var
      (begin
        (display "=" port)
        (cond ((eq? var closure-env-var)
               (write (map (lambda (var) (symbol->string (var-name var)))
                           (frame-closed frame))
                      port))
              ((eq? var ret-var)
               (display "RET" port))
              ((temp-var? var)
               (display "TMP" port))
              (else
               (write (symbol->string (var-name var)) port))))))

  (define (live? var)
    (let ((live (frame-live frame)))
      (or (set-member? var live)
          (and (eq? var closure-env-var)
               (not (set-empty? (set-intersection
                                  live
                                  (list->set (frame-closed frame)))))))))

  (display "{" port)
  (let loop1 ((i 1) (l (reverse (frame-slots frame))) (sep ""))
    (if (pair? l)
      (let ((var (car l)))
        (write-var (if (live? var) var #f) (make-stk i) sep)
        (loop1 (+ i 1) (cdr l) " "))
      (let loop2 ((i 0) (l (frame-regs frame)) (sep sep))
        (if (pair? l)
          (let ((var (car l)))
            (if (live? var)
              (begin
                (write-var var (make-reg i) sep)
                (loop2 (+ i 1) (cdr l) " "))
              (loop2 (+ i 1) (cdr l) sep)))
          (display "}" port))))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Operand writing:
; ---------------

(define (write-pvm-opnd pvm-opnd port)

  (define (write-opnd)
    (cond ((reg? pvm-opnd)
           (display "r" port)
           (+ 1 (write-returning-len (reg-num pvm-opnd) port)))
          ((stk? pvm-opnd)
           (display "s" port)
           (+ 1 (write-returning-len (stk-num pvm-opnd) port)))
          ((glo? pvm-opnd)
           (write-returning-len (symbol->string (glo-name pvm-opnd)) port))
          ((clo? pvm-opnd)
           (let ((x (write-pvm-opnd (clo-base pvm-opnd) port)))
             (display ":" port)
             (+ (write-returning-len (clo-index pvm-opnd) port) (+ x 1))))
          ((lbl? pvm-opnd)
           (display "L" port)
           (+ (write-returning-len (lbl-num pvm-opnd) port) 1))
          ((obj? pvm-opnd)
           (display "'" port)
           (+ (write-pvm-opnd-value (obj-val pvm-opnd) port) 1))
          (else
           (compiler-internal-error
             "write-pvm-opnd, unknown 'pvm-opnd':"
             pvm-opnd))))

  (if (pot-fut? pvm-opnd)
    (begin
      (display "?" port)
      (+ (write-opnd) 1))
    (write-opnd)))

(define (write-pvm-opnd-value val port)
  (cond ((false-object? val)
         (display "#f" port)
         2)
        ((undef-object? val)
         (display "#[undefined]" port)
         12)
        ((proc-obj? val)
         (if (proc-obj-primitive? val)
           (display "#[primitive " port)
           (display "#[procedure " port))
         (let ((x (display-returning-len (proc-obj-name val) port)))
           (display "]" port)
           (+ x 13)))
        (else
         (write-returning-len val port))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (virtual.begin!) ; initialize package
  (set! *opnd-table* (make-vector opnd-table-size))
  (set! *opnd-table-alloc* 0)
  '())

(define (virtual.end!) ; finalize package
  (set! *opnd-table* '())
  '())

;==============================================================================