home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Interp⁄Comp (.scm) / pvm.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  61.1 KB  |  1,750 lines  |  [TEXT/gamI]
  1. ;==============================================================================
  2.  
  3. ; file: "pvm.scm"
  4.  
  5. ;------------------------------------------------------------------------------
  6. ;
  7. ; Virtual machine abstraction package:
  8. ; -----------------------------------
  9.  
  10. ; (See file 'doc/pvm' for details on the virtual machine)
  11.  
  12. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  13. ;
  14. ; Virtual machine operands:
  15. ; ------------------------
  16. ;
  17. ; Operands are represented with small integers.  Operands can thus be tested
  18. ; for equality using 'eqv?'.  'eqv-opnd?' also tests for equal operands but
  19. ; it disregards the '?' flag.  The encoding is as follows:
  20. ;
  21. ; OPERAND      ENCODING         
  22. ;
  23. ; reg(n)       0     + n
  24. ; stk(n)       10000 + n
  25. ; lbl(n)       20000 + n
  26. ; glo(name)    30000 + index in operand table
  27. ; clo(opnd,n)  40000 + index in operand table
  28. ; obj(x)       50000 + index in operand table
  29. ; ?loc         60000 + encoding(loc)
  30.  
  31. ; Utilities:
  32. ; ---------
  33.  
  34. (define *opnd-table* '())
  35. (define *opnd-table-alloc* '())
  36.  
  37. (define opnd-table-size 10000)
  38.  
  39. (define (enter-opnd arg1 arg2)
  40.   (let loop ((i 0))
  41.     (if (< i *opnd-table-alloc*)
  42.       (let ((x (vector-ref *opnd-table* i)))
  43.         (if (and (eqv? (car x) arg1) (eqv? (cdr x) arg2))
  44.           i
  45.           (loop (+ i 1))))
  46.       (if (< *opnd-table-alloc* opnd-table-size)
  47.         (begin
  48.           (set! *opnd-table-alloc* (+ *opnd-table-alloc* 1))
  49.           (vector-set! *opnd-table* i (cons arg1 arg2))
  50.           i)
  51.         (compiler-limitation-error
  52.           "program is too long [virtual machine operand table overflow]")))))
  53.  
  54. (define (eqv-opnd? opnd1 opnd2)
  55.   (eqv? (strip-pot-fut opnd1) (strip-pot-fut opnd2)))
  56.  
  57. (define (contains-opnd? opnd1 opnd2) ; does opnd2 contain opnd1?
  58.   (cond ((eqv-opnd? opnd1 opnd2)
  59.          #t)
  60.         ((clo? opnd2)
  61.          (contains-opnd? opnd1 (clo-base opnd2)))
  62.         (else
  63.          #f)))
  64.  
  65. (define (any-contains-opnd? opnd opnds)
  66.   (if (null? opnds)
  67.     #f
  68.     (or (contains-opnd? opnd (car opnds))
  69.         (any-contains-opnd? opnd (cdr opnds)))))
  70.  
  71. ; Locations:
  72. ; ---------
  73.  
  74. ; -- location is a register (first is number 0)
  75. (define (make-reg num) num)
  76. (define (reg? x) (< (modulo x 60000) 10000))
  77. (define (reg-num x) (modulo x 10000))
  78.  
  79. ; -- location is in the stack (first slot in procedure's frame is number 1)
  80. (define (make-stk num) (+ num 10000))
  81. (define (stk? x) (= (quotient (modulo x 60000) 10000) 1))
  82. (define (stk-num x) (modulo x 10000))
  83.  
  84. ; -- location is a global variable
  85. (define (make-glo name) (+ (enter-opnd name #t) 30000))
  86. (define (glo? x) (= (quotient (modulo x 60000) 10000) 3))
  87. (define (glo-name x) (car (vector-ref *opnd-table* (modulo x 10000))))
  88.  
  89. ; -- location is a closed variable (base is ptr to closure env, index >= 1)
  90. (define (make-clo base index) (+ (enter-opnd base index) 40000))
  91. (define (clo? x) (= (quotient (modulo x 60000) 10000) 4))
  92. (define (clo-base x) (car (vector-ref *opnd-table* (modulo x 10000))))
  93. (define (clo-index x) (cdr (vector-ref *opnd-table* (modulo x 10000))))
  94.  
  95. ; Values:
  96. ; ------
  97.  
  98. ; -- value is the address of a local label
  99. (define (make-lbl num) (+ num 20000))
  100. (define (lbl? x) (= (quotient (modulo x 60000) 10000) 2))
  101. (define (lbl-num x) (modulo x 10000))
  102. (define label-limit 9999) ; largest label
  103.  
  104. ; -- value is a scheme object
  105. (define (make-obj val) (+ (enter-opnd val #f) 50000))                    
  106. (define (obj? x) (= (quotient (modulo x 60000) 10000) 5))         
  107. (define (obj-val x) (car (vector-ref *opnd-table* (modulo x 10000))))
  108.  
  109. ; Potentially future flag: (operands that should be touched to get their value)
  110. ; -----------------------
  111.  
  112. (define (put-pot-fut loc) (+ loc 60000))
  113. (define (pot-fut? x) (>= x 60000))
  114. (define (strip-pot-fut x) (modulo x 60000))
  115. (define (set-pot-fut loc flag) (if flag (put-pot-fut loc) loc))
  116.  
  117. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  118. ;
  119. ; Processor context descriptions:
  120. ; ------------------------------
  121.  
  122. (define (make-pcontext fs map)
  123.   (vector fs map))
  124.  
  125. (define (pcontext-fs  x) (vector-ref x 0))
  126. (define (pcontext-map x) (vector-ref x 1))
  127.  
  128. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  129. ;
  130. ; Frame description:
  131. ; -----------------
  132.  
  133. (define (make-frame size slots regs closed live)
  134.   (vector size slots regs closed live))
  135.  
  136. (define (frame-size x)   (vector-ref x 0))
  137. (define (frame-slots x)  (vector-ref x 1))
  138. (define (frame-regs x)   (vector-ref x 2))
  139. (define (frame-closed x) (vector-ref x 3))
  140. (define (frame-live x)   (vector-ref x 4))
  141.  
  142. (define (frame-eq? x y)
  143.   (= (frame-size x) (frame-size y)))
  144.  
  145. (define (frame-truncate frame nb-slots)
  146.   (let ((fs (frame-size frame)))
  147.     (make-frame nb-slots
  148.                 (nth-after (frame-slots frame) (- fs nb-slots))
  149.                 (frame-regs frame)
  150.                 (frame-closed frame)
  151.                 (frame-live frame))))
  152.  
  153. (define (frame-live? var frame)
  154.   (let ((live (frame-live frame)))
  155.     (if (eq? var closure-env-var)
  156.       (let ((closed (frame-closed frame)))
  157.         (if (or (set-member? var live)
  158.                 (not (set-empty? (set-intersection live (list->set closed)))))
  159.           closed
  160.           #f))
  161.       (if (set-member? var live)
  162.         var
  163.         #f))))
  164.  
  165. (define (frame-first-empty-slot frame)
  166.   (let loop ((i 1) (s (reverse (frame-slots frame))))
  167.     (if (pair? s)
  168.       (if (frame-live? (car s) frame)
  169.         (loop (+ i 1) (cdr s))
  170.         i)
  171.       i)))
  172.  
  173. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  174. ;
  175. ; Procedure objects:
  176. ; -----------------
  177.  
  178. (define (make-proc-obj
  179.           name
  180.           primitive?
  181.           code
  182.           call-pat
  183.           side-effects?
  184.           strict-pat
  185.           type)
  186.   (let ((proc-obj
  187.           (vector
  188.             proc-obj-tag
  189.             name
  190.             primitive?
  191.             code
  192.             call-pat
  193.             #f ; test
  194.             #f ; inlinable
  195.             #f ; specialize
  196.             side-effects?
  197.             strict-pat
  198.             type)))
  199.     (proc-obj-specialize-set! proc-obj (lambda (decls) proc-obj))
  200.     proc-obj))
  201.  
  202. (define proc-obj-tag (list 'PROC-OBJ))
  203.  
  204. (define (proc-obj? x)
  205.   (and (vector? x)
  206.        (> (vector-length x) 0)
  207.        (eq? (vector-ref x 0) proc-obj-tag)))
  208.  
  209. (define (proc-obj-name obj)                (vector-ref obj 1))
  210. (define (proc-obj-primitive? obj)          (vector-ref obj 2))
  211. (define (proc-obj-code obj)                (vector-ref obj 3))
  212. (define (proc-obj-call-pat obj)            (vector-ref obj 4))
  213. (define (proc-obj-test obj)                (vector-ref obj 5))
  214. (define (proc-obj-inlinable obj)           (vector-ref obj 6))
  215. (define (proc-obj-specialize obj)          (vector-ref obj 7))
  216. (define (proc-obj-side-effects? obj)       (vector-ref obj 8))
  217. (define (proc-obj-strict-pat obj)          (vector-ref obj 9))
  218. (define (proc-obj-type obj)                (vector-ref obj 10))
  219.  
  220. (define (proc-obj-code-set! obj x)         (vector-set! obj 3 x))
  221. (define (proc-obj-test-set! obj x)         (vector-set! obj 5 x))
  222. (define (proc-obj-inlinable-set! obj x)    (vector-set! obj 6 x))
  223. (define (proc-obj-specialize-set! obj x)   (vector-set! obj 7 x))
  224.  
  225. (define (make-pattern min-args nb-parms rest?)
  226.   (let loop ((x (if rest? (- nb-parms 1) (list nb-parms)))
  227.              (y (if rest? (- nb-parms 1) nb-parms)))
  228.     (let ((z (- y 1)))
  229.       (if (< z min-args) x (loop (cons z x) z)))))
  230.  
  231. (define (pattern-member? n pat) ; tests if 'n' is a member of pattern 'pat'
  232.   (cond ((pair? pat)
  233.          (if (= (car pat) n) #t (pattern-member? n (cdr pat))))
  234.         ((null? pat)
  235.          #f)
  236.         (else
  237.          (<= pat n))))
  238.  
  239. (define (type-name type)
  240.   (if (pair? type) (car type) type))
  241.  
  242. (define (type-pot-fut? type)
  243.   (pair? type))
  244.  
  245. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  246. ;
  247. ; Basic block set manipulation:
  248. ; ----------------------------
  249.  
  250. ; Virtual instructions have a linear structure.  However, this is not how
  251. ; they are put together to form a piece of code.  Rather, virtual instructions
  252. ; are grouped into 'basic blocks' which are 'linked' together.  A basic block
  253. ; is a LABEL instruction followed by a sequence of non-branching instructions
  254. ; (i.e. APPLY, COPY or MAKE_CLOSURES) terminated by a single branch
  255. ; instruction (i.e. COND or JUMP).  Links between basic
  256. ; blocks are denoted using label references.  When a basic block ends with a
  257. ; COND instruction, the block is linked to the two basic blocks corresponding
  258. ; to the two possible control paths out of the COND instruction.  When a basic
  259. ; block ends with a JUMP instruction, there is either zero or one link.
  260. ;
  261. ; Basic blocks naturally group together to form 'basic block sets'.  A basic
  262. ; block set describes all the code of a procedure.
  263.  
  264. (define (make-bbs)
  265.  
  266.   (define (limit-error)
  267.     (compiler-limitation-error "procedure is too long [too many labels]"))
  268.  
  269.   (vector (make-counter label-limit limit-error) ; 0 - local label counter
  270.           (queue-empty)                          ; 1 - basic block queue
  271.           '()))                                  ; 2 - entry label number
  272.  
  273. (define (bbs-lbl-counter bbs)                (vector-ref bbs 0))
  274. (define (bbs-bb-queue bbs)                   (vector-ref bbs 1))
  275. (define (bbs-bb-queue-set! bbs bbq)          (vector-set! bbs 1 bbq))
  276. (define (bbs-entry-lbl-num bbs)              (vector-ref bbs 2))
  277. (define (bbs-entry-lbl-num-set! bbs lbl-num) (vector-set! bbs 2 lbl-num))
  278.  
  279. (define (bbs-new-lbl! bbs)
  280.   ((bbs-lbl-counter bbs)))
  281.  
  282. (define (lbl-num->bb lbl-num bbs)
  283.   (let loop ((bb-list (queue->list (bbs-bb-queue bbs))))
  284.     (if (= (bb-lbl-num (car bb-list)) lbl-num)
  285.       (car bb-list)
  286.       (loop (cdr bb-list)))))
  287.  
  288. ; Basic block manipulation procedures:
  289.  
  290. (define (make-bb label-instr bbs)
  291.   (let ((bb (vector
  292.               label-instr   ; 0 - LABEL instr
  293.               (queue-empty) ; 1 - sequence of non-branching instrs
  294.               '()           ; 2 - branch instruction
  295.               '()           ; 3 - basic blocks referenced by this block
  296.               '())))        ; 4 - basic blocks which jump to this block
  297.                             ;     (both filled in by 'bbs-purify!')
  298.     (queue-put! (vector-ref bbs 1) bb)
  299.     bb))
  300.  
  301. (define (bb-lbl-num bb)                  (LABEL-lbl-num (vector-ref bb 0)))
  302. (define (bb-label-type bb)               (LABEL-type (vector-ref bb 0)))
  303. (define (bb-label-instr bb)              (vector-ref bb 0))
  304. (define (bb-label-instr-set! bb l)       (vector-set! bb 0 l))
  305. (define (bb-non-branch-instrs bb)        (queue->list (vector-ref bb 1)))
  306. (define (bb-non-branch-instrs-set! bb l) (vector-set! bb 1 (list->queue l)))
  307. (define (bb-branch-instr bb)             (vector-ref bb 2))
  308. (define (bb-branch-instr-set! bb b)      (vector-set! bb 2 b))
  309. (define (bb-references bb)               (vector-ref bb 3))
  310. (define (bb-references-set! bb l)        (vector-set! bb 3 l))
  311. (define (bb-precedents bb)               (vector-ref bb 4))
  312. (define (bb-precedents-set! bb l)        (vector-set! bb 4 l))
  313.  
  314. (define (bb-entry-frame-size bb)
  315.   (frame-size (pvm-instr-frame (bb-label-instr bb))))
  316.  
  317. (define (bb-exit-frame-size bb)
  318.   (frame-size (pvm-instr-frame (bb-branch-instr bb))))
  319.  
  320. (define (bb-slots-gained bb)
  321.   (- (bb-exit-frame-size bb) (bb-entry-frame-size bb)))
  322.  
  323. (define (bb-put-non-branch! bb pvm-instr)
  324.   (queue-put! (vector-ref bb 1) pvm-instr))
  325.  
  326. (define (bb-put-branch! bb pvm-instr)
  327.   (vector-set! bb 2 pvm-instr))
  328.  
  329. (define (bb-add-reference! bb ref)
  330.   (if (not (memq ref (vector-ref bb 3)))
  331.     (vector-set! bb 3 (cons ref (vector-ref bb 3)))))
  332.  
  333. (define (bb-add-precedent! bb prec)
  334.   (if (not (memq prec (vector-ref bb 4)))
  335.     (vector-set! bb 4 (cons prec (vector-ref bb 4)))))
  336.  
  337. ; Virtual machine instruction representation:
  338.  
  339. (define (pvm-instr-type pvm-instr)    (vector-ref pvm-instr 0))
  340. (define (pvm-instr-frame pvm-instr)   (vector-ref pvm-instr 1))
  341. (define (pvm-instr-comment pvm-instr) (vector-ref pvm-instr 2))
  342.  
  343. (define (make-LABEL-SIMP lbl-num frame comment)
  344.   (vector 'LABEL frame comment lbl-num 'SIMP))
  345.  
  346. (define (make-LABEL-TASK lbl-num method frame comment)
  347.   (vector 'LABEL frame comment lbl-num 'TASK method))
  348.  
  349. (define (make-LABEL-PROC lbl-num nb-parms min rest? closed? frame comment)
  350.   (vector 'LABEL frame comment lbl-num 'PROC nb-parms min rest? closed?))
  351.  
  352. (define (make-LABEL-RETURN lbl-num task-method frame comment)
  353.   (vector 'LABEL frame comment lbl-num 'RETURN task-method))
  354.  
  355. (define (LABEL-lbl-num pvm-instr)            (vector-ref pvm-instr 3))
  356. (define (LABEL-type pvm-instr)               (vector-ref pvm-instr 4))
  357.  
  358. (define (LABEL-TASK-method pvm-instr)        (vector-ref pvm-instr 5))
  359.  
  360. (define (LABEL-PROC-nb-parms pvm-instr)      (vector-ref pvm-instr 5))
  361. (define (LABEL-PROC-min pvm-instr)           (vector-ref pvm-instr 6))
  362. (define (LABEL-PROC-rest? pvm-instr)         (vector-ref pvm-instr 7))
  363. (define (LABEL-PROC-closed? pvm-instr)       (vector-ref pvm-instr 8))
  364.  
  365. (define (LABEL-RETURN-task-method pvm-instr) (vector-ref pvm-instr 5))
  366.  
  367. (define (make-APPLY prim opnds loc frame comment)
  368.   (vector 'APPLY frame comment prim opnds loc))
  369. (define (APPLY-prim pvm-instr)  (vector-ref pvm-instr 3))
  370. (define (APPLY-opnds pvm-instr) (vector-ref pvm-instr 4))
  371. (define (APPLY-loc pvm-instr)   (vector-ref pvm-instr 5))
  372.  
  373. (define (make-COPY opnd loc frame comment)
  374.   (vector 'COPY frame comment opnd loc))
  375.  
  376. (define (COPY-opnd pvm-instr) (vector-ref pvm-instr 3))
  377. (define (COPY-loc pvm-instr)  (vector-ref pvm-instr 4))
  378.  
  379. (define (make-MAKE_CLOSURES parms frame comment)
  380.   (vector 'MAKE_CLOSURES frame comment parms))
  381. (define (MAKE_CLOSURES-parms pvm-instr) (vector-ref pvm-instr 3))
  382.  
  383. (define (make-closure-parms loc lbl opnds)
  384.   (vector loc lbl opnds))
  385. (define (closure-parms-loc x)   (vector-ref x 0))
  386. (define (closure-parms-lbl x)   (vector-ref x 1))
  387. (define (closure-parms-opnds x) (vector-ref x 2))
  388.  
  389. (define (make-COND test opnds true false intr-check? frame comment)
  390.   (vector 'COND frame comment test opnds true false intr-check?))
  391. (define (COND-test pvm-instr)        (vector-ref pvm-instr 3))
  392. (define (COND-opnds pvm-instr)       (vector-ref pvm-instr 4))
  393. (define (COND-true pvm-instr)        (vector-ref pvm-instr 5))
  394. (define (COND-false pvm-instr)       (vector-ref pvm-instr 6))
  395. (define (COND-intr-check? pvm-instr) (vector-ref pvm-instr 7))
  396.  
  397. (define (make-JUMP opnd nb-args intr-check? frame comment)
  398.   (vector 'JUMP frame comment opnd nb-args intr-check?))
  399. (define (JUMP-opnd pvm-instr)         (vector-ref pvm-instr 3))
  400. (define (JUMP-nb-args pvm-instr)      (vector-ref pvm-instr 4))
  401. (define (JUMP-intr-check? pvm-instr)  (vector-ref pvm-instr 5))
  402. (define (first-class-JUMP? pvm-instr) (JUMP-nb-args pvm-instr))
  403.  
  404. (define (make-comment)
  405.   (cons 'COMMENT '()))
  406.  
  407. (define (comment-put! comment name val)
  408.   (set-cdr! comment (cons (cons name val) (cdr comment))))
  409.  
  410. (define (comment-get comment name)
  411.   (and comment
  412.        (let ((x (assq name (cdr comment))))
  413.          (if x (cdr x) #f))))
  414.  
  415. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  416. ;
  417. ; 'Purification' of basic block sets:
  418. ; ----------------------------------
  419.  
  420. ; This step removes unreachable basic blocks (i.e. dead code), duplicate
  421. ; basic blocks (i.e. common code) and jump cascades from a basic block set.
  422. ; It also orders the basic blocks so that the destination of a branch is put
  423. ; (if possible) right after the branch instruction.  The 'references' and
  424. ; 'precedents' fields of each basic block are also filled in through the
  425. ; process.  The first basic block of a 'purified' basic block set is always
  426. ; the entry point.
  427.  
  428. (define (bbs-purify! bbs)
  429.   (let loop () ; iterate until no more code to remove
  430.     (bbs-remove-jump-cascades! bbs)
  431.     (bbs-remove-dead-code! bbs)
  432.     (if pvm-opts?
  433.       (if (bbs-remove-common-code! bbs) (loop) (bbs-order! bbs))
  434.       (bbs-bb-queue-set! bbs
  435.         (list->queue
  436.           (sort-list (queue->list (bbs-bb-queue bbs))
  437.                      (lambda (x y) (< (bb-lbl-num x) (bb-lbl-num y)))))))))
  438.  
  439. (define pvm-opts? #f)
  440. (set! pvm-opts? #t)
  441.  
  442. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  443.  
  444. ; Step 1, Jump cascade removal:
  445.  
  446. (define (bbs-remove-jump-cascades! bbs)
  447.  
  448.   (define (empty-bb? bb)
  449.     (and (eq? (bb-label-type bb) 'SIMP)       ; simple label and
  450.          (null? (bb-non-branch-instrs bb))))  ; no non-branching instrs
  451.  
  452.   (define (jump-lbl? branch)
  453.     (let ((opnd (JUMP-opnd branch)))
  454.       (if (lbl? opnd) (lbl-num opnd) #f)))
  455.  
  456.   (define (jump-to-non-entry-lbl? branch)
  457.     (and (eq? (pvm-instr-type branch) 'JUMP)
  458.          (not (first-class-JUMP? branch)) ; not a jump to an entry label
  459.          (jump-lbl? branch)))
  460.  
  461.   (define (jump-cascade-to lbl-num fs intr-check? seen thunk)
  462.     (if (memq lbl-num seen) ; infinite loop?
  463.       (thunk lbl-num fs intr-check?)
  464.       (let ((bb (lbl-num->bb lbl-num bbs)))
  465.         (if (and (empty-bb? bb) (<= (bb-slots-gained bb) 0))
  466.           (let ((jump-lbl-num
  467.                  (jump-to-non-entry-lbl? (bb-branch-instr bb))))
  468.             (if jump-lbl-num
  469.               (jump-cascade-to
  470.                 jump-lbl-num
  471.                 (+ fs (bb-slots-gained bb))
  472.                 (or intr-check? (JUMP-intr-check? (bb-branch-instr bb)))
  473.                 (cons lbl-num seen)
  474.                 thunk)
  475.               (thunk lbl-num fs intr-check?)))
  476.           (thunk lbl-num fs intr-check?)))))
  477.  
  478.   (define (equiv-lbl lbl-num seen)
  479.     (if (memq lbl-num seen) ; infinite loop?
  480.       lbl-num
  481.       (let ((bb (lbl-num->bb lbl-num bbs)))
  482.         (if (empty-bb? bb)
  483.           (let ((jump-lbl-num
  484.                  (jump-to-non-entry-lbl? (bb-branch-instr bb))))
  485.             (if (and jump-lbl-num
  486.                      (not (JUMP-intr-check? (bb-branch-instr bb)))
  487.                      (= (bb-slots-gained bb) 0))
  488.               (equiv-lbl jump-lbl-num (cons lbl-num seen))
  489.               lbl-num))
  490.           lbl-num))))
  491.  
  492.   (define (remove-cascade! bb)
  493.     (let ((branch (bb-branch-instr bb)))
  494.  
  495.       (case (pvm-instr-type branch)
  496.  
  497.         ((COND)
  498.          (bb-put-branch! bb  ; branch is a COND
  499.            (make-COND (COND-test branch)
  500.                       (COND-opnds branch)
  501.                       (equiv-lbl (COND-true branch) '())
  502.                       (equiv-lbl (COND-false branch) '())
  503.                       (COND-intr-check? branch)
  504.                       (pvm-instr-frame branch)
  505.                       (pvm-instr-comment branch))))
  506.  
  507.         ((JUMP)  ; branch is a JUMP
  508.          (if (not (first-class-JUMP? branch)) ; but not to an entry label
  509.            (let ((dest-lbl-num (jump-lbl? branch)))
  510.              (if dest-lbl-num
  511.  
  512.                (jump-cascade-to
  513.                  dest-lbl-num
  514.                  (frame-size (pvm-instr-frame branch))
  515.                  (JUMP-intr-check? branch)
  516.                  '()
  517.                  (lambda (lbl-num fs intr-check?)
  518.                    (let* ((dest-bb (lbl-num->bb lbl-num bbs))
  519.                           (last-branch (bb-branch-instr dest-bb)))
  520.                      (if (and (empty-bb? dest-bb)
  521.                               (or (not intr-check?)
  522.                                   put-intr-check-on-COND?
  523.                                   (not (eq? (pvm-instr-type last-branch) 'COND))))
  524.  
  525.                        (let* ((new-fs (+ fs (bb-slots-gained dest-bb)))
  526.                               (new-frame (frame-truncate
  527.                                            (pvm-instr-frame branch)
  528.                                            new-fs)))
  529.  
  530.                          (define (adjust-opnd opnd)
  531.                            (cond ((stk? opnd)
  532.                                   (set-pot-fut
  533.                                     (make-stk
  534.                                       (+ (- fs (bb-entry-frame-size dest-bb))
  535.                                          (stk-num opnd)))
  536.                                     (pot-fut? opnd)))
  537.                                  ((clo? opnd)
  538.                                   (set-pot-fut
  539.                                     (make-clo (adjust-opnd (clo-base opnd))
  540.                                               (clo-index opnd))
  541.                                     (pot-fut? opnd)))
  542.                                  (else
  543.                                   opnd)))
  544.  
  545.                          (case (pvm-instr-type last-branch)
  546.                            ((COND)
  547.                             (bb-put-branch! bb
  548.                               (make-COND (COND-test last-branch)
  549.                                          (map adjust-opnd (COND-opnds last-branch))
  550.                                          (equiv-lbl (COND-true last-branch) '())
  551.                                          (equiv-lbl (COND-false last-branch) '())
  552.                                          (or intr-check?
  553.                                              (COND-intr-check? last-branch))
  554.                                          new-frame
  555.                                          (pvm-instr-comment last-branch))))
  556.                            ((JUMP)
  557.                             (bb-put-branch! bb
  558.                               (make-JUMP (adjust-opnd (JUMP-opnd last-branch))
  559.                                          (JUMP-nb-args last-branch)
  560.                                          (or intr-check?
  561.                                              (JUMP-intr-check? last-branch))
  562.                                          new-frame
  563.                                          (pvm-instr-comment last-branch))))
  564.                            (else
  565.                             (compiler-internal-error
  566.                               "bbs-remove-jump-cascades!, unknown branch type"))))
  567.  
  568.                        (bb-put-branch! bb
  569.                          (make-JUMP (make-lbl lbl-num)
  570.                                     (JUMP-nb-args branch)
  571.                                     (or intr-check?
  572.                                         (JUMP-intr-check? branch))
  573.                                     (frame-truncate
  574.                                       (pvm-instr-frame branch)
  575.                                       fs)
  576.                                     (pvm-instr-comment branch)))))))))))
  577.  
  578.         (else
  579.          (compiler-internal-error
  580.            "bbs-remove-jump-cascades!, unknown branch type")))))
  581.  
  582.   (for-each remove-cascade!
  583.             (queue->list (bbs-bb-queue bbs))))
  584.  
  585. (define put-intr-check-on-COND? #f)
  586. (set! put-intr-check-on-COND? #t)
  587.  
  588. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  589.  
  590. ; Step 2, Dead code removal:
  591.  
  592. (define (bbs-remove-dead-code! bbs)
  593.  
  594.   (let ((new-bb-queue (queue-empty))
  595.         (scan-queue (queue-empty)))
  596.  
  597.     (define (reachable ref bb)
  598.       (if bb (bb-add-reference! bb ref))
  599.       (if (not (memq ref (queue->list new-bb-queue)))
  600.         (begin
  601.           (bb-references-set! ref '())
  602.           (bb-precedents-set! ref '())
  603.           (queue-put! new-bb-queue ref)
  604.           (queue-put! scan-queue ref))))
  605.  
  606.     (define (direct-jump to-bb from-bb)
  607.       (reachable to-bb from-bb)
  608.       (bb-add-precedent! to-bb from-bb))
  609.  
  610.     (define (scan-instr pvm-instr bb)
  611.  
  612.       (define (scan-opnd pvm-opnd)
  613.         (cond ((lbl? pvm-opnd)
  614.                (reachable (lbl-num->bb (lbl-num pvm-opnd) bbs) bb))
  615.               ((clo? pvm-opnd)
  616.                (scan-opnd (clo-base pvm-opnd)))))
  617.  
  618.       (case (pvm-instr-type pvm-instr)
  619.  
  620.         ((LABEL)
  621.          '())
  622.  
  623.         ((APPLY)
  624.          (for-each scan-opnd (APPLY-opnds pvm-instr))
  625.          (if (APPLY-loc pvm-instr)
  626.            (scan-opnd (APPLY-loc pvm-instr))))
  627.  
  628.         ((COPY)
  629.          (scan-opnd (COPY-opnd pvm-instr))
  630.          (scan-opnd (COPY-loc pvm-instr)))
  631.  
  632.         ((MAKE_CLOSURES)
  633.          (for-each (lambda (parm)
  634.                      (reachable (lbl-num->bb (closure-parms-lbl parm) bbs) bb)
  635.                      (scan-opnd (closure-parms-loc parm))
  636.                      (for-each scan-opnd (closure-parms-opnds parm)))
  637.                    (MAKE_CLOSURES-parms pvm-instr)))
  638.  
  639.         ((COND)
  640.          (for-each scan-opnd (COND-opnds pvm-instr))
  641.          (direct-jump (lbl-num->bb (COND-true pvm-instr) bbs) bb)
  642.          (direct-jump (lbl-num->bb (COND-false pvm-instr) bbs) bb))
  643.  
  644.         ((JUMP)
  645.          (let ((opnd (JUMP-opnd pvm-instr)))
  646.            (if (lbl? opnd)
  647.              (direct-jump (lbl-num->bb (lbl-num opnd) bbs) bb)
  648.              (scan-opnd (JUMP-opnd pvm-instr)))))
  649.  
  650.         (else
  651.          (compiler-internal-error
  652.            "bbs-remove-dead-code!, unknown PVM instruction type"))))
  653.  
  654.     (reachable (lbl-num->bb (bbs-entry-lbl-num bbs) bbs) #f)
  655.  
  656.     (let loop ()
  657.       (if (not (queue-empty? scan-queue))
  658.         (let ((bb (queue-get! scan-queue)))
  659.           (begin
  660.             (scan-instr (bb-label-instr bb) bb)
  661.             (for-each (lambda (pvm-instr) (scan-instr pvm-instr bb))
  662.                       (bb-non-branch-instrs bb))
  663.             (scan-instr (bb-branch-instr bb) bb)
  664.             (loop)))))
  665.  
  666.     (bbs-bb-queue-set! bbs new-bb-queue)))
  667.  
  668. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  669.  
  670. ; Step 3, Common code removal:
  671.  
  672. (define (bbs-remove-common-code! bbs)
  673.   (let* ((bb-list (queue->list (bbs-bb-queue bbs)))
  674.          (n (length bb-list))
  675.          (hash-table-length
  676.            (cond ((< n 50)  43) ; select reasonable size for hash table
  677.                  ((< n 500) 403)
  678.                  (else      4003)))
  679.          (hash-table (make-vector hash-table-length '()))
  680.          (prim-table '())
  681.          (block-map '())
  682.          (changed? #f))
  683.  
  684.   (define (hash-prim prim)
  685.     (let ((n (length prim-table))
  686.           (i (pos-in-list prim prim-table)))
  687.       (if i
  688.         (- n i)
  689.         (begin
  690.           (set! prim-table (cons prim prim-table))
  691.           (+ n 1)))))
  692.  
  693.   (define (hash-opnds l) ; this assumes that operands are encoded with nbs
  694.     (let loop ((l l) (n 0))
  695.       (if (pair? l)
  696.         (loop (cdr l)
  697.               (let ((x (car l)))
  698.                 (if (lbl? x) n (modulo (+ (* n 10000) x) hash-table-length))))
  699.         n)))
  700.  
  701.   (define (hash-bb bb) ; compute hash address for a basic block
  702.     (let ((branch (bb-branch-instr bb)))
  703.       (modulo
  704.         (case (pvm-instr-type branch)
  705.           ((COND)
  706.            (+ (hash-opnds (COND-opnds branch))
  707.               (* 10 (hash-prim (COND-test branch)))
  708.               (* 100 (frame-size (pvm-instr-frame branch)))))
  709.           ((JUMP)
  710.            (+ (hash-opnds (list (JUMP-opnd branch)))
  711.               (* 10 (or (JUMP-nb-args branch) -1))
  712.               (* 100 (frame-size (pvm-instr-frame branch)))))
  713.           (else
  714.            0))
  715.         hash-table-length)))
  716.  
  717.   (define (replacement-lbl-num lbl)
  718.     (let ((x (assv lbl block-map)))
  719.       (if x (cdr x) lbl)))
  720.  
  721.   (define (fix-map! bb1 bb2) ; bb1 should be replaced by bb2 in the block-map
  722.     (let loop ((l block-map))
  723.       (if (pair? l)
  724.         (let ((x (car l)))
  725.           (if (= bb1 (cdr x)) (set-cdr! x bb2))
  726.           (loop (cdr l))))))
  727.  
  728.   (define (enter-bb! bb) ; enter a basic block in the hash table
  729.     (let ((h (hash-bb bb)))
  730.       (vector-set! hash-table h
  731.         (add-bb bb (vector-ref hash-table h)))))
  732.  
  733.   (define (add-bb bb l) ; add basic block 'bb' to list of basic blocks
  734.     (if (pair? l)
  735.       (let ((bb* (car l))) ; pick next basic block in list
  736.  
  737.         (set! block-map ; for now, assume that 'bb' = 'bb*'
  738.           (cons (cons (bb-lbl-num bb) (bb-lbl-num bb*))
  739.                 block-map))
  740.  
  741.         (if (eqv-bb? bb bb*) ; are they the same?
  742.  
  743.           (begin
  744.             (fix-map! (bb-lbl-num bb) (bb-lbl-num bb*)) ; record the equivalence
  745.             (set! changed? #t)
  746.             l)
  747.  
  748.           (begin
  749.             (set! block-map (cdr block-map)) ; they are not the same!
  750.             (if (eqv-pvm-instr? (bb-branch-instr bb) (bb-branch-instr bb*))
  751.  
  752.               (extract-common-tail bb bb* ; check if tail is the same
  753.                 (lambda (head head* tail)
  754.                   (if (null? tail) ; common tail long enough?
  755.  
  756.                     (cons bb* (add-bb bb (cdr l))) ; no, so try rest of list
  757.  
  758.                     (let* ((lbl (bbs-new-lbl! bbs)) ; create bb for common tail
  759.                            (branch (bb-branch-instr bb))
  760.                            (fs** (need-pvm-instrs tail branch))
  761.                            (frame (frame-truncate
  762.                                     (pvm-instr-frame
  763.                                       (if (null? head)
  764.                                         (bb-label-instr bb)
  765.                                         (car head)))
  766.                                     fs**))
  767.                            (bb** (make-bb (make-LABEL-SIMP lbl frame #f) bbs)))
  768.                       (bb-non-branch-instrs-set! bb** tail)
  769.                       (bb-branch-instr-set! bb** branch)
  770.                       (bb-non-branch-instrs-set! bb* (reverse head*))
  771.                       (bb-branch-instr-set! bb*
  772.                         (make-JUMP (make-lbl lbl) #f #f frame #f))
  773.                       (bb-non-branch-instrs-set! bb (reverse head))
  774.                       (bb-branch-instr-set! bb
  775.                         (make-JUMP (make-lbl lbl) #f #f frame #f))
  776.                       (set! changed? #t)
  777.                       (cons bb (cons bb* (add-bb bb** (cdr l))))))))
  778.  
  779.                 (cons bb* (add-bb bb (cdr l)))))))
  780.  
  781.         (list bb)))
  782.  
  783.   (define (extract-common-tail bb1 bb2 cont)
  784.     (let loop ((l1 (reverse (bb-non-branch-instrs bb1)))
  785.                (l2 (reverse (bb-non-branch-instrs bb2)))
  786.                (tail '()))
  787.       (if (and (pair? l1) (pair? l2))
  788.         (let ((i1 (car l1))
  789.               (i2 (car l2)))
  790.           (if (eqv-pvm-instr? i1 i2)
  791.             (loop (cdr l1) (cdr l2) (cons i1 tail))
  792.             (cont l1 l2 tail)))
  793.         (cont l1 l2 tail))))
  794.  
  795.   (define (eqv-bb? bb1 bb2)
  796.     (let ((bb1-non-branch (bb-non-branch-instrs bb1))
  797.           (bb2-non-branch (bb-non-branch-instrs bb2)))
  798.       (and (= (length bb1-non-branch) (length bb2-non-branch))
  799.            (eqv-pvm-instr? (bb-label-instr bb1) (bb-label-instr bb2))
  800.            (eqv-pvm-instr? (bb-branch-instr bb1) (bb-branch-instr bb2))
  801.            (eqv-list? eqv-pvm-instr? bb1-non-branch bb2-non-branch))))
  802.  
  803.   (define (eqv-list? pred? l1 l2)
  804.     (if (pair? l1)
  805.       (and (pair? l2)
  806.            (pred? (car l1) (car l2))
  807.            (eqv-list? pred? (cdr l1) (cdr l2)))
  808.       (not (pair? l2))))
  809.  
  810.   (define (eqv-lbl-num? lbl1 lbl2)
  811.     (= (replacement-lbl-num lbl1)
  812.        (replacement-lbl-num lbl2)))
  813.  
  814.   (define (eqv-pvm-opnd? opnd1 opnd2)
  815.     (if (not opnd1)
  816.       (not opnd2)
  817.       (and opnd2
  818.            (eq? (pot-fut? opnd1) (pot-fut? opnd2))
  819.            (cond ((lbl? opnd1)
  820.                   (and (lbl? opnd2)
  821.                        (eqv-lbl-num? (lbl-num opnd1) (lbl-num opnd2))))
  822.                  ((clo? opnd1)
  823.                   (and (clo? opnd2)
  824.                        (= (clo-index opnd1) (clo-index opnd2))
  825.                        (eqv-pvm-opnd? (clo-base opnd1)
  826.                                       (clo-base opnd2))))
  827.                  (else
  828.                   (eqv? opnd1 opnd2))))))
  829.     
  830.   (define (eqv-pvm-instr? instr1 instr2)
  831.  
  832.     (define (eqv-closure-parms? p1 p2)
  833.       (and (eqv-pvm-opnd? (closure-parms-loc p1)
  834.                           (closure-parms-loc p2))
  835.            (eqv-lbl-num? (closure-parms-lbl p1)
  836.                          (closure-parms-lbl p2))
  837.            (eqv-list? eqv-pvm-opnd?
  838.                       (closure-parms-opnds p1)
  839.                       (closure-parms-opnds p2))))
  840.  
  841.     (let ((type1 (pvm-instr-type instr1))
  842.           (type2 (pvm-instr-type instr2)))
  843.       (and (eq? type1 type2)
  844.            (frame-eq? (pvm-instr-frame instr1) (pvm-instr-frame instr2))
  845.            (case type1
  846.  
  847.              ((LABEL)
  848.               (let ((ltype1 (LABEL-type instr1))
  849.                     (ltype2 (LABEL-type instr2)))
  850.                 (and (eq? ltype1 ltype2)
  851.                      (case ltype1
  852.                        ((SIMP)
  853.                         #t)
  854.                        ((TASK)
  855.                         (eq? (LABEL-TASK-method instr1)
  856.                              (LABEL-TASK-method instr2)))
  857.                        ((RETURN)
  858.                         (eq? (LABEL-RETURN-task-method instr1)
  859.                              (LABEL-RETURN-task-method instr2)))
  860.                        ((PROC)
  861.                         (and (= (LABEL-PROC-min instr1)
  862.                                 (LABEL-PROC-min instr2))
  863.                              (= (LABEL-PROC-nb-parms instr1)
  864.                                 (LABEL-PROC-nb-parms instr2))
  865.                              (eq? (LABEL-PROC-rest? instr1)
  866.                                   (LABEL-PROC-rest? instr2))
  867.                              (eq? (LABEL-PROC-closed? instr1)
  868.                                   (LABEL-PROC-closed? instr2))))
  869.                        (else
  870.                         (compiler-internal-error
  871.                           "eqv-pvm-instr?, unknown label type"))))))
  872.  
  873.              ((APPLY)
  874.               (and (eq? (APPLY-prim instr1) (APPLY-prim instr2))
  875.                    (eqv-list? eqv-pvm-opnd?
  876.                               (APPLY-opnds instr1)
  877.                               (APPLY-opnds instr2))
  878.                    (eqv-pvm-opnd? (APPLY-loc instr1)
  879.                                   (APPLY-loc instr2))))
  880.  
  881.              ((COPY)
  882.               (and (eqv-pvm-opnd? (COPY-opnd instr1)
  883.                                   (COPY-opnd instr2))
  884.                    (eqv-pvm-opnd? (COPY-loc instr1)
  885.                                   (COPY-loc instr2))))
  886.  
  887.              ((MAKE_CLOSURES)
  888.               (eqv-list? eqv-closure-parms?
  889.                          (MAKE_CLOSURES-parms instr1)
  890.                          (MAKE_CLOSURES-parms instr2)))
  891.  
  892.              ((COND)
  893.               (and (eq? (COND-test instr1)
  894.                         (COND-test instr2))
  895.                    (eqv-list? eqv-pvm-opnd?
  896.                               (COND-opnds instr1)
  897.                               (COND-opnds instr2))
  898.                    (eqv-lbl-num? (COND-true instr1)
  899.                                  (COND-true instr2))
  900.                    (eqv-lbl-num? (COND-false instr1)
  901.                                  (COND-false instr2))
  902.                    (eq? (COND-intr-check? instr1)
  903.                         (COND-intr-check? instr2))))
  904.  
  905.              ((JUMP)
  906.               (and (eqv-pvm-opnd? (JUMP-opnd instr1)
  907.                                   (JUMP-opnd instr2))
  908.                    (eqv? (JUMP-nb-args instr1)
  909.                          (JUMP-nb-args instr2))
  910.                    (eq? (JUMP-intr-check? instr1)
  911.                         (JUMP-intr-check? instr2))))
  912.  
  913.              (else
  914.               (compiler-internal-error
  915.                 "eqv-pvm-instr?, unknown 'pvm-instr':" instr1))))))
  916.  
  917.   (define (update-pvm-opnd opnd)
  918.     (if opnd
  919.       (cond ((lbl? opnd)
  920.              (set-pot-fut
  921.                (make-lbl (replacement-lbl-num (lbl-num opnd)))
  922.                (pot-fut? opnd)))
  923.             ((clo? opnd)
  924.              (set-pot-fut
  925.                (make-clo (update-pvm-opnd (clo-base opnd)) (clo-index opnd))
  926.                (pot-fut? opnd)))
  927.             (else
  928.              opnd))
  929.       opnd))
  930.  
  931.   (define (update-pvm-instr instr)
  932.  
  933.     (define (update-closure-parms p)
  934.       (make-closure-parms
  935.         (update-pvm-opnd (closure-parms-loc p))
  936.         (replacement-lbl-num (closure-parms-lbl p))
  937.         (map update-pvm-opnd (closure-parms-opnds p))))
  938.  
  939.     (case (pvm-instr-type instr)
  940.  
  941.       ((LABEL)
  942.        (case (LABEL-type instr)
  943.          ((SIMP)
  944.           (make-LABEL-SIMP (LABEL-lbl-num instr)
  945.                            (pvm-instr-frame instr)
  946.                            (pvm-instr-comment instr)))
  947.          ((TASK)
  948.           (make-LABEL-TASK (LABEL-lbl-num instr)
  949.                            (LABEL-TASK-method instr)
  950.                            (pvm-instr-frame instr)
  951.                            (pvm-instr-comment instr)))
  952.          ((PROC)
  953.           (make-LABEL-PROC (LABEL-lbl-num instr)
  954.                            (LABEL-PROC-nb-parms instr)
  955.                            (LABEL-PROC-min instr)
  956.                            (LABEL-PROC-rest? instr)
  957.                            (LABEL-PROC-closed? instr)
  958.                            (pvm-instr-frame instr)
  959.                            (pvm-instr-comment instr)))
  960.          ((RETURN)
  961.           (make-LABEL-RETURN (LABEL-lbl-num instr)
  962.                              (LABEL-RETURN-task-method instr)
  963.                              (pvm-instr-frame instr)
  964.                              (pvm-instr-comment instr)))
  965.          (else
  966.           (compiler-internal-error
  967.             "update-pvm-instr, unknown label type"))))
  968.  
  969.       ((APPLY)
  970.        (make-APPLY (APPLY-prim instr)
  971.                    (map update-pvm-opnd (APPLY-opnds instr))
  972.                    (update-pvm-opnd (APPLY-loc instr))
  973.                    (pvm-instr-frame instr)
  974.                    (pvm-instr-comment instr)))
  975.  
  976.       ((COPY)
  977.        (make-COPY (update-pvm-opnd (COPY-opnd instr))
  978.                   (update-pvm-opnd (COPY-loc instr))
  979.                   (pvm-instr-frame instr)
  980.                   (pvm-instr-comment instr)))
  981.  
  982.       ((MAKE_CLOSURES)
  983.        (make-MAKE_CLOSURES
  984.          (map update-closure-parms (MAKE_CLOSURES-parms instr))
  985.          (pvm-instr-frame instr)
  986.          (pvm-instr-comment instr)))
  987.  
  988.       ((COND)
  989.        (make-COND (COND-test instr)
  990.                   (map update-pvm-opnd (COND-opnds instr))
  991.                   (replacement-lbl-num (COND-true instr))
  992.                   (replacement-lbl-num (COND-false instr))
  993.                   (COND-intr-check? instr)
  994.                   (pvm-instr-frame instr)
  995.                   (pvm-instr-comment instr)))
  996.  
  997.       ((JUMP)
  998.        (make-JUMP (update-pvm-opnd (JUMP-opnd instr))
  999.                   (JUMP-nb-args instr)
  1000.                   (JUMP-intr-check? instr)
  1001.                   (pvm-instr-frame instr)
  1002.                   (pvm-instr-comment instr)))
  1003.  
  1004.       (else
  1005.        (compiler-internal-error
  1006.          "update-pvm-instr, unknown 'instr':" instr))))
  1007.  
  1008.   (define (update-bb! bb)
  1009.     (bb-label-instr-set! bb
  1010.       (update-pvm-instr (bb-label-instr bb)))
  1011.     (bb-non-branch-instrs-set! bb
  1012.       (map update-pvm-instr (bb-non-branch-instrs bb)))
  1013.     (bb-branch-instr-set! bb
  1014.       (update-pvm-instr (bb-branch-instr bb))))
  1015.  
  1016.   ; Fill hash table, remove equivalent basic blocks and common tails
  1017.  
  1018.   (for-each enter-bb! bb-list)
  1019.  
  1020.   ; Reconstruct bbs
  1021.  
  1022.   (bbs-entry-lbl-num-set! bbs
  1023.     (replacement-lbl-num (bbs-entry-lbl-num bbs)))
  1024.  
  1025.   (let loop ((i 0) (result '()))
  1026.     (if (< i hash-table-length)
  1027.       (let ((bb-kept (vector-ref hash-table i)))
  1028.         (for-each update-bb! bb-kept)
  1029.         (loop (+ i 1) (append bb-kept result)))
  1030.       (bbs-bb-queue-set! bbs (list->queue result))))
  1031.  
  1032.   changed?))
  1033.  
  1034. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1035.  
  1036. ; Step 4, Basic block set ordering:
  1037.  
  1038. (define (bbs-order! bbs)
  1039.  
  1040.   (let ((new-bb-queue (queue-empty))
  1041.         (left-to-schedule (queue->list (bbs-bb-queue bbs))))
  1042.  
  1043.     (define (remove x l)
  1044.       (if (eq? (car l) x)
  1045.         (cdr l)
  1046.         (cons (car l) (remove x (cdr l)))))
  1047.  
  1048.     ; update list of basic blocks not yet scheduled
  1049.  
  1050.     (define (remove-bb! bb)
  1051.       (set! left-to-schedule (remove bb left-to-schedule))
  1052.       bb)
  1053.  
  1054.     ; return a basic block which ends with a branch to 'bb' (and that is
  1055.     ; still in 'left-to-schedule') or #f if there aren't any
  1056.  
  1057.     (define (prec-bb bb)
  1058.       (let loop ((l (bb-precedents bb)) (best #f) (best-fs #f))
  1059.         (if (null? l)
  1060.           best
  1061.           (let* ((x (car l))
  1062.                  (x-fs (bb-exit-frame-size x)))
  1063.             (if (and (memq x left-to-schedule)
  1064.                      (or (not best) (< x-fs best-fs)))
  1065.               (loop (cdr l) x x-fs)
  1066.               (loop (cdr l) best best-fs))))))
  1067.  
  1068.     ; return the basic block which 'bb' jumps to (and that is still in
  1069.     ; 'left-to-schedule') or #f if there aren't any
  1070.  
  1071.     (define (succ-bb bb)
  1072.  
  1073.       (define (branches-to-lbl? bb)
  1074.         (let ((branch (bb-branch-instr bb)))
  1075.           (case (pvm-instr-type branch)
  1076.             ((COND) #t)
  1077.             ((JUMP) (lbl? (JUMP-opnd branch)))
  1078.             (else
  1079.              (compiler-internal-error
  1080.               "bbs-order!, unknown branch type")))))
  1081.  
  1082.       (define (best-succ bb1 bb2)   ; heuristic that determines which
  1083.         (if (branches-to-lbl? bb1)  ; bb is most frequently executed
  1084.            bb1
  1085.            (if (branches-to-lbl? bb2)
  1086.              bb2
  1087.              (if (< (bb-exit-frame-size bb1)
  1088.                     (bb-exit-frame-size bb2))
  1089.                bb2
  1090.                bb1))))
  1091.  
  1092.       (let ((branch (bb-branch-instr bb)))
  1093.         (case (pvm-instr-type branch)
  1094.           ((COND)
  1095.            (let* ((true-bb (lbl-num->bb (COND-true branch) bbs))
  1096.                   (true-bb* (and (memq true-bb left-to-schedule)
  1097.                                  true-bb))
  1098.                   (false-bb (lbl-num->bb (COND-false branch) bbs))
  1099.                   (false-bb* (and (memq false-bb left-to-schedule)
  1100.                                   false-bb)))
  1101.              (if (and true-bb* false-bb*)
  1102.                (best-succ true-bb* false-bb*)
  1103.                (or true-bb* false-bb*))))
  1104.           ((JUMP)
  1105.            (let ((opnd (JUMP-opnd branch)))
  1106.              (and (lbl? opnd)
  1107.                   (let ((bb (lbl-num->bb (lbl-num opnd) bbs)))
  1108.                     (and (memq bb left-to-schedule) bb)))))
  1109.           (else
  1110.            (compiler-internal-error
  1111.              "bbs-order!, unknown branch type")))))
  1112.  
  1113.     ; schedule a given basic block 'bb' with it's predecessors and
  1114.     ; successors.
  1115.  
  1116.     (define (schedule-from bb)
  1117.       (queue-put! new-bb-queue bb)
  1118.       (let ((x (succ-bb bb)))
  1119.         (if x
  1120.           (begin
  1121.             (schedule-around (remove-bb! x))
  1122.             (let ((y (succ-bb bb)))
  1123.               (if y
  1124.                 (schedule-around (remove-bb! y)))))))
  1125.       (schedule-refs bb))
  1126.  
  1127.     (define (schedule-around bb)
  1128.       (let ((x (prec-bb bb)))
  1129.         (if x
  1130.           (let ((bb-list (schedule-back (remove-bb! x) '())))
  1131.             (queue-put! new-bb-queue x)
  1132.             (schedule-forw bb)
  1133.             (for-each schedule-refs bb-list))
  1134.           (schedule-from bb))))
  1135.  
  1136.     (define (schedule-back bb bb-list)
  1137.       (let ((bb-list* (cons bb bb-list))
  1138.             (x (prec-bb bb)))
  1139.         (if x
  1140.           (let ((bb-list (schedule-back (remove-bb! x) bb-list*)))
  1141.             (queue-put! new-bb-queue x)
  1142.             bb-list)
  1143.           bb-list*)))
  1144.  
  1145.     (define (schedule-forw bb)
  1146.       (queue-put! new-bb-queue bb)
  1147.       (let ((x (succ-bb bb)))
  1148.         (if x
  1149.           (begin
  1150.             (schedule-forw (remove-bb! x))
  1151.             (let ((y (succ-bb bb)))
  1152.               (if y
  1153.                 (schedule-around (remove-bb! y)))))))
  1154.       (schedule-refs bb))
  1155.  
  1156.     (define (schedule-refs bb)
  1157.       (for-each
  1158.         (lambda (x)
  1159.           (if (memq x left-to-schedule) (schedule-around (remove-bb! x))))
  1160.         (bb-references bb)))
  1161.  
  1162.     (schedule-from (remove-bb! (lbl-num->bb (bbs-entry-lbl-num bbs) bbs)))
  1163.  
  1164.     (bbs-bb-queue-set! bbs new-bb-queue)))
  1165.  
  1166. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1167. ;
  1168. ; Sequentialization of a basic block set:
  1169. ; --------------------------------------
  1170.  
  1171. ; The procedure 'bbs->code-list' transforms a 'purified' basic block set
  1172. ; into a sequence of virtual machine instructions.  Each element of the
  1173. ; resulting list is a 'code' object that contains a PVM instruction,
  1174. ; a pointer to the basic block it came from and a `slots needed' index
  1175. ; that specifies the minimum number of slots that have to be kept (relative
  1176. ; to the start of the frame) after the instruction is executed.
  1177. ; The procedure does a few optimizations: fall-through JUMP removal and
  1178. ; deletion of unnecessary LABELs.  The first element of the code list is the
  1179. ; entry label for the piece of code.
  1180.  
  1181. (define (make-code bb pvm-instr sn)     (vector bb pvm-instr sn))
  1182. (define (code-bb code)                  (vector-ref code 0))
  1183. (define (code-pvm-instr code)           (vector-ref code 1))
  1184. (define (code-slots-needed code)        (vector-ref code 2))
  1185. (define (code-slots-needed-set! code n) (vector-set! code 2 n))
  1186.  
  1187. (define (bbs->code-list bbs)
  1188.   (let ((code-list (linearize bbs)))
  1189.     (setup-slots-needed! code-list)
  1190.     code-list))
  1191.  
  1192. (define (linearize bbs) ; turn bbs into list and remove LABELs & JUMPs
  1193.  
  1194.   (let ((code-queue (queue-empty)))
  1195.  
  1196.     (define (put-bb prec-bb pres-bb next-bb label-needed?)
  1197.  
  1198.       (define (put-instr pvm-instr)
  1199.         (queue-put! code-queue (make-code pres-bb pvm-instr #f)))
  1200.  
  1201.       (if label-needed?
  1202.         (put-instr (bb-label-instr pres-bb))) ; put label only if truly needed
  1203.  
  1204.       (for-each put-instr (bb-non-branch-instrs pres-bb)) ; put non-branching instrs
  1205.  
  1206.       (let ((branch (bb-branch-instr pres-bb)))
  1207.         (case (pvm-instr-type branch)
  1208.           ((COND)
  1209.            (put-instr branch)
  1210.            #t)
  1211.  
  1212.           ((JUMP)
  1213.            (let ((opnd (JUMP-opnd branch)))
  1214.              (if (or (not next-bb) ; remove JUMP if it falls through?
  1215.                      (not (lbl? opnd))
  1216.                      (not (= (lbl-num opnd) (bb-lbl-num next-bb)))
  1217.                      (not (= (length (bb-precedents next-bb)) 1))
  1218.                      (not (eq? (bb-label-type next-bb) 'SIMP)) ; not a simple label
  1219.                      (not (= (frame-size (pvm-instr-frame branch))
  1220.                              (bb-entry-frame-size next-bb)))
  1221.                      (JUMP-intr-check? branch))
  1222.                (begin (put-instr branch) #t)
  1223.                #f)))
  1224.  
  1225.           (else
  1226.            (compiler-internal-error
  1227.              "linearize, unknown branch type")))))
  1228.  
  1229.     (let loop ((l (queue->list (bbs-bb-queue bbs)))
  1230.                (prev-bb #f)
  1231.                (label-needed? #t))
  1232.       (if (not (null? l))
  1233.         (let ((pres-bb (car l)))
  1234.           (loop (cdr l)
  1235.                 pres-bb
  1236.                 (put-bb prev-bb
  1237.                         pres-bb
  1238.                         (if (null? (cdr l)) #f (cadr l))
  1239.                         label-needed?)))))
  1240.  
  1241.     (queue->list code-queue)))
  1242.  
  1243. (define (setup-slots-needed! code-list) ; setup `slots-needed' field
  1244.   (if (null? code-list)
  1245.     #f
  1246.     (let* ((code (car code-list))
  1247.            (pvm-instr (code-pvm-instr code))
  1248.            (sn-rest (setup-slots-needed! (cdr code-list))))
  1249.  
  1250.       (case (pvm-instr-type pvm-instr)
  1251.  
  1252.         ((LABEL)
  1253.          (if (> sn-rest (frame-size (pvm-instr-frame pvm-instr)))
  1254.            (compiler-internal-error
  1255.              "setup-slots-needed!, incoherent slots needed for LABEL"))
  1256.          (code-slots-needed-set! code sn-rest)
  1257.          #f)
  1258.  
  1259.         ((COND JUMP)
  1260.          (let ((sn (frame-size (pvm-instr-frame pvm-instr))))
  1261.            (code-slots-needed-set! code sn)
  1262.            (need-pvm-instr pvm-instr sn)))
  1263.      
  1264.         (else 
  1265.          (code-slots-needed-set! code sn-rest)
  1266.          (need-pvm-instr pvm-instr sn-rest))))))
  1267.  
  1268. (define (need-pvm-instrs non-branch branch)
  1269.   (if (pair? non-branch)
  1270.     (need-pvm-instr (car non-branch)
  1271.                     (need-pvm-instrs (cdr non-branch) branch))
  1272.     (need-pvm-instr branch (frame-size (pvm-instr-frame branch)))))
  1273.  
  1274. (define (need-pvm-instr pvm-instr sn-rest)
  1275.   (case (pvm-instr-type pvm-instr)
  1276.  
  1277.     ((LABEL)
  1278.      sn-rest)
  1279.  
  1280.     ((APPLY)
  1281.      (let ((loc (APPLY-loc pvm-instr)))
  1282.        (need-pvm-opnds (APPLY-opnds pvm-instr)
  1283.          (need-pvm-loc-opnd loc
  1284.            (need-pvm-loc loc sn-rest)))))
  1285.  
  1286.     ((COPY)
  1287.      (let ((loc (COPY-loc pvm-instr)))
  1288.        (need-pvm-opnd (COPY-opnd pvm-instr)
  1289.          (need-pvm-loc-opnd loc
  1290.            (need-pvm-loc loc sn-rest)))))
  1291.  
  1292.     ((MAKE_CLOSURES)
  1293.      (let ((parms (MAKE_CLOSURES-parms pvm-instr)))
  1294.  
  1295.        (define (need-parms-opnds p)
  1296.          (if (null? p)
  1297.            sn-rest
  1298.            (need-pvm-opnds (closure-parms-opnds (car p))
  1299.              (need-parms-opnds (cdr p)))))
  1300.  
  1301.        (define (need-parms-loc p)
  1302.          (if (null? p)
  1303.            (need-parms-opnds parms)
  1304.            (let ((loc (closure-parms-loc (car p))))
  1305.              (need-pvm-loc-opnd loc
  1306.                (need-pvm-loc loc (need-parms-loc (cdr p)))))))
  1307.  
  1308.        (need-parms-loc parms)))
  1309.  
  1310.     ((COND)
  1311.      (need-pvm-opnds (COND-opnds pvm-instr) sn-rest))
  1312.  
  1313.     ((JUMP)
  1314.      (need-pvm-opnd (JUMP-opnd pvm-instr) sn-rest))
  1315.      
  1316.     (else 
  1317.      (compiler-internal-error
  1318.        "need-pvm-instr, unknown 'pvm-instr':" pvm-instr))))
  1319.  
  1320. (define (need-pvm-loc loc sn-rest)
  1321.   (if (and loc (stk? loc) (>= (stk-num loc) sn-rest))
  1322.     (- (stk-num loc) 1)
  1323.     sn-rest))
  1324.  
  1325. (define (need-pvm-loc-opnd pvm-loc slots-needed)
  1326.   (if (and pvm-loc (clo? pvm-loc))
  1327.     (need-pvm-opnd (clo-base pvm-loc) slots-needed)
  1328.     slots-needed))
  1329.  
  1330. (define (need-pvm-opnd pvm-opnd slots-needed)
  1331.   (cond ((stk? pvm-opnd)
  1332.          (max (stk-num pvm-opnd) slots-needed))
  1333.         ((clo? pvm-opnd)
  1334.          (need-pvm-opnd (clo-base pvm-opnd) slots-needed))
  1335.         (else
  1336.          slots-needed)))
  1337.  
  1338. (define (need-pvm-opnds pvm-opnds slots-needed)
  1339.   (if (null? pvm-opnds)
  1340.     slots-needed
  1341.     (need-pvm-opnd (car pvm-opnds)
  1342.                    (need-pvm-opnds (cdr pvm-opnds) slots-needed))))
  1343.  
  1344. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1345. ;
  1346. ; Basic block writing:
  1347. ; -------------------
  1348.  
  1349. (define (write-bb bb port)
  1350.   (write-pvm-instr (bb-label-instr bb) port)
  1351.   (display " [precedents=" port)
  1352.   (write (map bb-lbl-num (bb-precedents bb)) port)
  1353.   (display "]" port)
  1354.   (newline port)
  1355.  
  1356.   (for-each (lambda (x) (write-pvm-instr x port) (newline port))
  1357.             (bb-non-branch-instrs bb))
  1358.  
  1359.   (write-pvm-instr (bb-branch-instr bb) port))
  1360.  
  1361. (define (write-bbs bbs port)
  1362.   (for-each (lambda (bb)
  1363.               (if (= (bb-lbl-num bb) (bbs-entry-lbl-num bbs))
  1364.                 (begin (display "**** Entry block:" port) (newline port)))
  1365.               (write-bb bb port)
  1366.               (newline port))
  1367.             (queue->list (bbs-bb-queue bbs))))
  1368.  
  1369. (define (virtual.dump proc port)
  1370.  
  1371.   (let ((proc-seen (queue-empty))
  1372.         (proc-left (queue-empty)))
  1373.  
  1374.     (define (scan-opnd pvm-opnd)
  1375.       (cond ((obj? pvm-opnd)
  1376.              (let ((val (obj-val pvm-opnd)))
  1377.                (if (and (proc-obj? val)
  1378.                         (proc-obj-code val)
  1379.                         (not (memq val (queue->list proc-seen))))
  1380.                  (begin
  1381.                    (queue-put! proc-seen val)
  1382.                    (queue-put! proc-left val)))))
  1383.             ((clo? pvm-opnd)
  1384.              (scan-opnd (clo-base pvm-opnd)))))
  1385.  
  1386.     (define (dump-proc p)
  1387.  
  1388.       (define (scan-code code)
  1389.         (let ((pvm-instr (code-pvm-instr code))
  1390.               (slots-needed (code-slots-needed code)))
  1391.           (if (> slots-needed 9) (display "[" port) (display "[ " port))
  1392.           (display slots-needed port)
  1393.           (display "] " port)
  1394.  
  1395.           (write-pvm-instr pvm-instr port)
  1396.           (newline port)
  1397.           (case (pvm-instr-type pvm-instr)
  1398.  
  1399.             ((APPLY)
  1400.              (for-each scan-opnd (APPLY-opnds pvm-instr))
  1401.              (if (APPLY-loc pvm-instr)
  1402.                (scan-opnd (APPLY-loc pvm-instr))))
  1403.  
  1404.             ((COPY)
  1405.              (scan-opnd (COPY-opnd pvm-instr))
  1406.              (scan-opnd (COPY-loc pvm-instr)))
  1407.  
  1408.             ((MAKE_CLOSURES)
  1409.              (for-each (lambda (parms)
  1410.                          (scan-opnd (closure-parms-loc parms))
  1411.                          (for-each scan-opnd (closure-parms-opnds parms)))
  1412.                        (MAKE_CLOSURES-parms pvm-instr)))
  1413.  
  1414.             ((COND)
  1415.              (for-each scan-opnd (COND-opnds pvm-instr)))
  1416.  
  1417.             ((JUMP)
  1418.              (scan-opnd (JUMP-opnd pvm-instr)))
  1419.  
  1420.             (else
  1421.              '()))))
  1422.  
  1423.       (if (proc-obj-primitive? p)
  1424.         (display "**** #[primitive " port)
  1425.         (display "**** #[procedure " port))
  1426.       (display (proc-obj-name p) port)
  1427.       (display "] =" port)
  1428.       (newline port)
  1429.  
  1430.       (for-each scan-code (bbs->code-list (proc-obj-code p)))
  1431.  
  1432.       (newline port))
  1433.        
  1434.     (scan-opnd (make-obj proc))
  1435.  
  1436.     (let loop ()
  1437.       (if (not (queue-empty? proc-left))
  1438.         (begin
  1439.           (dump-proc (queue-get! proc-left))
  1440.           (loop))))))
  1441.  
  1442. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1443. ;
  1444. ; Virtual instruction writing:
  1445. ; ---------------------------
  1446.  
  1447. (define (write-pvm-instr pvm-instr port)
  1448.  
  1449.   (define (write-closure-parms parms)
  1450.     (let ((len (write-pvm-opnd (closure-parms-loc parms) port)))
  1451.       (display ",L" port)
  1452.       (let ((len (+ len (+ 2 (write-returning-len
  1453.                                (closure-parms-lbl parms)
  1454.                                port)))))
  1455.         (let loop ((l (closure-parms-opnds parms)) (len len))
  1456.           (if (pair? l)
  1457.             (let ((opnd (car l)))
  1458.               (display "," port)
  1459.               (loop (cdr l) (+ len (+ (write-pvm-opnd opnd port) 1))))
  1460.             len)))))
  1461.  
  1462.   (define (write-upcase str)
  1463.     (let ((len (string-length str)))
  1464.       (let loop ((i 0))
  1465.         (if (< i len)
  1466.           (begin
  1467.             (write-char (char-upcase (string-ref str i)) port)
  1468.             (loop (+ i 1)))
  1469.           len))))
  1470.  
  1471.   (define (write-task-method method)
  1472.     (if method
  1473.       (begin
  1474.         (display "," port)
  1475.         (+ 1 (write-upcase (symbol->string method))))
  1476.       0))
  1477.  
  1478.   (define (write-instr pvm-instr)
  1479.     (case (pvm-instr-type pvm-instr)
  1480.  
  1481.       ((LABEL)
  1482.        (display "LABEL(L" port)
  1483.        (let ((len (+ 7 (write-returning-len (LABEL-lbl-num pvm-instr) port))))
  1484.          (case (LABEL-type pvm-instr)
  1485.            ((SIMP)
  1486.             (display ",SIMP)" port)
  1487.             (+ len 6))
  1488.            ((TASK)
  1489.             (display ",TASK" port)
  1490.             (let ((len (+ len
  1491.                           (+ 5
  1492.                              (write-task-method
  1493.                                (LABEL-TASK-method pvm-instr))))))
  1494.               (display ")" port)
  1495.               (+ len 1)))
  1496.            ((PROC)
  1497.             (display ",PROC," port)
  1498.             (let ((len (+ len
  1499.                           (+ 6
  1500.                              (if (not (= (LABEL-PROC-min pvm-instr)
  1501.                                          (LABEL-PROC-nb-parms pvm-instr)))
  1502.                                (let ((len (+ len
  1503.                                              (write-returning-len
  1504.                                                (LABEL-PROC-min pvm-instr)
  1505.                                                port))))
  1506.                                  (display "-" port)
  1507.                                  (+ len 1))
  1508.                                0)))))
  1509.               (let ((len (+ len
  1510.                             (write-returning-len
  1511.                               (LABEL-PROC-nb-parms pvm-instr)
  1512.                               port))))
  1513.                 (let ((len (+ len
  1514.                               (if (LABEL-PROC-rest? pvm-instr)
  1515.                                 (begin (display "..." port) 3)
  1516.                                 0))))
  1517.                   (let ((len (+ len
  1518.                                 (if (LABEL-PROC-closed? pvm-instr)
  1519.                                   (begin (display ",CLOSED" port) 7)
  1520.                                   0))))
  1521.                     (display ")" port)
  1522.                     (+ len 1))))))
  1523.            ((RETURN)
  1524.             (display ",RETURN" port)
  1525.             (let ((len (+ len
  1526.                           (+ 7
  1527.                              (write-task-method
  1528.                                (LABEL-RETURN-task-method pvm-instr))))))
  1529.               (display ")" port)
  1530.               (+ len 1)))
  1531.            (else
  1532.             (compiler-internal-error
  1533.               "write-pvm-instr, unknown label type")))))
  1534.  
  1535.       ((APPLY)
  1536.        (display "  APPLY(" port)
  1537.        (let ((len (+ 8 (display-returning-len
  1538.                          (proc-obj-name (APPLY-prim pvm-instr))
  1539.                          port))))
  1540.           (let loop ((l (APPLY-opnds pvm-instr)) (len len))
  1541.             (if (pair? l)
  1542.               (let ((opnd (car l)))
  1543.                 (display "," port)
  1544.                 (loop (cdr l) (+ len (+ (write-pvm-opnd opnd port) 1))))
  1545.               (begin
  1546.                 (display "," port)
  1547.                 (let ((len (+ len
  1548.                               (+ 1
  1549.                                  (if (APPLY-loc pvm-instr)
  1550.                                    (write-pvm-opnd (APPLY-loc pvm-instr) port)
  1551.                                    0)))))
  1552.                   (display ")" port)
  1553.                   (+ len 1)))))))
  1554.  
  1555.       ((COPY)
  1556.        (display "  COPY(" port)
  1557.        (let ((len (+ 7 (write-pvm-opnd (COPY-opnd pvm-instr) port))))
  1558.          (display "," port)
  1559.          (let ((len (+ len (+ 1 (write-pvm-opnd (COPY-loc pvm-instr) port)))))
  1560.            (display ")" port)
  1561.            (+ len 1))))
  1562.  
  1563.       ((MAKE_CLOSURES)
  1564.        (display "  MAKE_CLOSURES(" port)
  1565.        (let ((len (+ 16 (write-closure-parms
  1566.                           (car (MAKE_CLOSURES-parms pvm-instr))))))
  1567.          (let loop ((l (cdr (MAKE_CLOSURES-parms pvm-instr))) (len len))
  1568.            (if (pair? l)
  1569.              (let ((x (car l)))
  1570.                (display "/" port)
  1571.                (loop (cdr l) (+ len (+ (write-closure-parms x) 1))))
  1572.              (begin
  1573.                (display ")" port)
  1574.                (+ len 1))))))
  1575.  
  1576.       ((COND)
  1577.        (display "  COND(" port)
  1578.        (let ((len (+ 7 (display-returning-len
  1579.                          (proc-obj-name (COND-test pvm-instr))
  1580.                          port))))
  1581.          (let loop ((l (COND-opnds pvm-instr)) (len len))
  1582.            (if (pair? l)
  1583.              (let ((opnd (car l)))
  1584.                (display "," port)
  1585.                (loop (cdr l) (+ len (+ (write-pvm-opnd opnd port) 1))))
  1586.              (begin
  1587.                (display ",L" port)
  1588.                (let ((len (+ len (+ 2 (write-returning-len
  1589.                                         (COND-true pvm-instr)
  1590.                                         port)))))
  1591.                  (display ",L" port)
  1592.                  (let ((len (+ len (+ 2 (write-returning-len
  1593.                                           (COND-false pvm-instr)
  1594.                                           port)))))
  1595.                    (let ((len (+ len (if (COND-intr-check? pvm-instr)
  1596.                                        (begin (display ",INTR-CHECK" port) 11)
  1597.                                        0))))
  1598.                      (display ")" port)
  1599.                      (+ len 1)))))))))
  1600.  
  1601.       ((JUMP)
  1602.        (display "  JUMP(" port)
  1603.        (let ((len (+ 7 (write-pvm-opnd (JUMP-opnd pvm-instr) port))))
  1604.          (let ((len (+ len (if (JUMP-nb-args pvm-instr)
  1605.                              (begin
  1606.                                (display "," port)
  1607.                                (+ 1 (write-returning-len
  1608.                                       (JUMP-nb-args pvm-instr)
  1609.                                       port)))
  1610.                              0))))
  1611.            (let ((len (+ len (if (JUMP-intr-check? pvm-instr)
  1612.                                (begin (display ",INTR-CHECK" port) 11)
  1613.                                0))))
  1614.              (display ")" port)
  1615.              (+ len 1)))))
  1616.  
  1617.       (else
  1618.        (compiler-internal-error
  1619.          "write-pvm-instr, unknown 'pvm-instr':"
  1620.          pvm-instr))))
  1621.  
  1622.   (define (spaces n)
  1623.     (if (> n 0)
  1624.       (if (> n 7)
  1625.         (begin (display "        " port) (spaces (- n 8)))
  1626.         (begin (display " " port) (spaces (- n 1))))))
  1627.  
  1628.   (let ((len (write-instr pvm-instr)))
  1629.     (spaces (- 80 len))
  1630.     (display " " port)
  1631.     (write-frame (pvm-instr-frame pvm-instr) port))
  1632.  
  1633.   (let ((x (pvm-instr-comment pvm-instr)))
  1634.     (if x
  1635.       (let ((y (comment-get x 'TEXT)))
  1636.         (if y
  1637.           (begin
  1638.             (display " ; " port)
  1639.             (display y port)))))))
  1640.  
  1641. (define (write-frame frame port)
  1642.  
  1643.   (define (write-var var opnd sep)
  1644.     (display sep port)
  1645.     (write-pvm-opnd opnd port)
  1646.     (if var
  1647.       (begin
  1648.         (display "=" port)
  1649.         (cond ((eq? var closure-env-var)
  1650.                (write (map (lambda (var) (symbol->string (var-name var)))
  1651.                            (frame-closed frame))
  1652.                       port))
  1653.               ((eq? var ret-var)
  1654.                (display "RET" port))
  1655.               ((temp-var? var)
  1656.                (display "TMP" port))
  1657.               (else
  1658.                (write (symbol->string (var-name var)) port))))))
  1659.  
  1660.   (define (live? var)
  1661.     (let ((live (frame-live frame)))
  1662.       (or (set-member? var live)
  1663.           (and (eq? var closure-env-var)
  1664.                (not (set-empty? (set-intersection
  1665.                                   live
  1666.                                   (list->set (frame-closed frame)))))))))
  1667.  
  1668.   (display "{" port)
  1669.   (let loop1 ((i 1) (l (reverse (frame-slots frame))) (sep ""))
  1670.     (if (pair? l)
  1671.       (let ((var (car l)))
  1672.         (write-var (if (live? var) var #f) (make-stk i) sep)
  1673.         (loop1 (+ i 1) (cdr l) " "))
  1674.       (let loop2 ((i 0) (l (frame-regs frame)) (sep sep))
  1675.         (if (pair? l)
  1676.           (let ((var (car l)))
  1677.             (if (live? var)
  1678.               (begin
  1679.                 (write-var var (make-reg i) sep)
  1680.                 (loop2 (+ i 1) (cdr l) " "))
  1681.               (loop2 (+ i 1) (cdr l) sep)))
  1682.           (display "}" port))))))
  1683.  
  1684. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1685. ;
  1686. ; Operand writing:
  1687. ; ---------------
  1688.  
  1689. (define (write-pvm-opnd pvm-opnd port)
  1690.  
  1691.   (define (write-opnd)
  1692.     (cond ((reg? pvm-opnd)
  1693.            (display "r" port)
  1694.            (+ 1 (write-returning-len (reg-num pvm-opnd) port)))
  1695.           ((stk? pvm-opnd)
  1696.            (display "s" port)
  1697.            (+ 1 (write-returning-len (stk-num pvm-opnd) port)))
  1698.           ((glo? pvm-opnd)
  1699.            (write-returning-len (symbol->string (glo-name pvm-opnd)) port))
  1700.           ((clo? pvm-opnd)
  1701.            (let ((x (write-pvm-opnd (clo-base pvm-opnd) port)))
  1702.              (display ":" port)
  1703.              (+ (write-returning-len (clo-index pvm-opnd) port) (+ x 1))))
  1704.           ((lbl? pvm-opnd)
  1705.            (display "L" port)
  1706.            (+ (write-returning-len (lbl-num pvm-opnd) port) 1))
  1707.           ((obj? pvm-opnd)
  1708.            (display "'" port)
  1709.            (+ (write-pvm-opnd-value (obj-val pvm-opnd) port) 1))
  1710.           (else
  1711.            (compiler-internal-error
  1712.              "write-pvm-opnd, unknown 'pvm-opnd':"
  1713.              pvm-opnd))))
  1714.  
  1715.   (if (pot-fut? pvm-opnd)
  1716.     (begin
  1717.       (display "?" port)
  1718.       (+ (write-opnd) 1))
  1719.     (write-opnd)))
  1720.  
  1721. (define (write-pvm-opnd-value val port)
  1722.   (cond ((false-object? val)
  1723.          (display "#f" port)
  1724.          2)
  1725.         ((undef-object? val)
  1726.          (display "#[undefined]" port)
  1727.          12)
  1728.         ((proc-obj? val)
  1729.          (if (proc-obj-primitive? val)
  1730.            (display "#[primitive " port)
  1731.            (display "#[procedure " port))
  1732.          (let ((x (display-returning-len (proc-obj-name val) port)))
  1733.            (display "]" port)
  1734.            (+ x 13)))
  1735.         (else
  1736.          (write-returning-len val port))))
  1737.  
  1738. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1739.  
  1740. (define (virtual.begin!) ; initialize package
  1741.   (set! *opnd-table* (make-vector opnd-table-size))
  1742.   (set! *opnd-table-alloc* 0)
  1743.   '())
  1744.  
  1745. (define (virtual.end!) ; finalize package
  1746.   (set! *opnd-table* '())
  1747.   '())
  1748.  
  1749. ;==============================================================================
  1750.