gsc/_gvm.scm

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