gsc/_gvm.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "_gvm.scm", Time-stamp: <2010-06-10 16:31:50 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         (define (has-debug-info? instr)
 991           (let ((node (comment-get (gvm-instr-comment instr) 'node)))
 992             (and node
 993                  (let ((env (node-env node)))
 994                    (and (debug? env)
 995                         (or (debug-location? env)
 996                             (debug-source? env)
 997                             (debug-environments? env)))))))
 998
 999         (let ((type1 (gvm-instr-type instr1))
1000               (type2 (gvm-instr-type instr2)))
1001           (and (eq? type1 type2)
1002                (frame-eq? (gvm-instr-frame instr1) (gvm-instr-frame instr2))
1003                (not (has-debug-info? instr1))
1004                (not (has-debug-info? instr2))
1005                (case type1
1006
1007                  ((label)
1008                   (let ((ltype1 (label-type instr1))
1009                         (ltype2 (label-type instr2)))
1010                     (and (eq? ltype1 ltype2)
1011                          (case ltype1
1012                            ((simple return task-entry task-return)
1013                             #t)
1014                            ((entry)
1015                             (and (= (label-entry-nb-parms instr1)
1016                                     (label-entry-nb-parms instr2))
1017                                  (eqv-list? eqv-gvm-opnd?
1018                                             (label-entry-opts instr1)
1019                                             (label-entry-opts instr2))
1020                                  (if (label-entry-keys instr1)
1021                                    (and (label-entry-keys instr2)
1022                                         (eqv-list? eqv-key-pair?
1023                                                    (label-entry-keys instr1)
1024                                                    (label-entry-keys instr2)))
1025                                    (not (label-entry-keys instr2)))
1026                                  (eq? (label-entry-rest? instr1)
1027                                       (label-entry-rest? instr2))
1028                                  (eq? (label-entry-closed? instr1)
1029                                       (label-entry-closed? instr2))))
1030                            (else
1031                             (compiler-internal-error
1032                               "eqv-gvm-instr?, unknown label type"))))))
1033
1034                  ((apply)
1035                   (and (eq? (apply-prim instr1) (apply-prim instr2))
1036                        (eqv-list? eqv-gvm-opnd?
1037                                   (apply-opnds instr1)
1038                                   (apply-opnds instr2))
1039                        (eqv-gvm-opnd? (apply-loc instr1)
1040                                       (apply-loc instr2))))
1041
1042                  ((copy)
1043                   (and (eqv-gvm-opnd? (copy-opnd instr1)
1044                                       (copy-opnd instr2))
1045                        (eqv-gvm-opnd? (copy-loc instr1)
1046                                       (copy-loc instr2))))
1047
1048                  ((close)
1049                   (eqv-list? eqv-closure-parms?
1050                              (close-parms instr1)
1051                              (close-parms instr2)))
1052
1053                  ((ifjump)
1054                   (and (eq? (ifjump-test instr1)
1055                             (ifjump-test instr2))
1056                        (eqv-list? eqv-gvm-opnd?
1057                                   (ifjump-opnds instr1)
1058                                   (ifjump-opnds instr2))
1059                        (eqv-lbl-num? (ifjump-true instr1)
1060                                      (ifjump-true instr2))
1061                        (eqv-lbl-num? (ifjump-false instr1)
1062                                      (ifjump-false instr2))
1063                        (eq? (ifjump-poll? instr1)
1064                             (ifjump-poll? instr2))))
1065
1066                  ((switch)
1067                   (and (eqv-gvm-opnd? (switch-opnd instr1)
1068                                       (switch-opnd instr2))
1069                        (every? (lambda (x)
1070                                  (and (eqv? (switch-case-obj (car x))
1071                                             (switch-case-obj (cdr x)))
1072                                       (eqv-lbl-num? (switch-case-lbl (car x))
1073                                                     (switch-case-lbl (cdr x)))))
1074                                (map cons
1075                                     (switch-cases instr1)
1076                                     (switch-cases instr2)))
1077                        (eqv-lbl-num? (switch-default instr1)
1078                                      (switch-default instr2))
1079                        (eq? (switch-poll? instr1)
1080                             (switch-poll? instr2))))
1081
1082                  ((jump)
1083                   (and (eqv-gvm-opnd? (jump-opnd instr1)
1084                                       (jump-opnd instr2))
1085                        (eqv? (jump-nb-args instr1)
1086                              (jump-nb-args instr2))
1087                        (eq? (jump-poll? instr1)
1088                             (jump-poll? instr2))
1089                        (eq? (jump-safe? instr1)
1090                             (jump-safe? instr2))))
1091
1092                  (else
1093                   (compiler-internal-error
1094                     "eqv-gvm-instr?, unknown 'gvm-instr':" instr1))))))
1095
1096       ; Fill hash table, remove equivalent basic blocks and common tails
1097
1098       (bbs-for-each-bb enter-bb! bbs)
1099
1100       ; Reconstruct bbs
1101
1102       (bbs-entry-lbl-num-set! bbs
1103         (replacement-lbl-num (bbs-entry-lbl-num bbs)))
1104
1105       (bbs-for-each-bb
1106         (lambda (bb)
1107           (if bb
1108             (replace-label-references! bb replacement-lbl-num)))
1109         bbs)
1110
1111       changed?))))
1112
1113 (define (replace-label-references! bb replacement-lbl-num)
1114
1115   (define (update-gvm-opnd opnd)
1116     (if opnd
1117       (cond ((lbl? opnd)
1118              (make-lbl (replacement-lbl-num (lbl-num opnd))))
1119             ((clo? opnd)
1120              (make-clo (update-gvm-opnd (clo-base opnd)) (clo-index opnd)))
1121             (else
1122              opnd))
1123       opnd))
1124
1125   (define (update-gvm-instr instr)
1126
1127     (define (update-closure-parms p)
1128       (make-closure-parms
1129         (update-gvm-opnd (closure-parms-loc p))
1130         (replacement-lbl-num (closure-parms-lbl p))
1131         (map update-gvm-opnd (closure-parms-opnds p))))
1132
1133     (case (gvm-instr-type instr)
1134
1135       ((apply)
1136        (make-apply (apply-prim instr)
1137                    (map update-gvm-opnd (apply-opnds instr))
1138                    (update-gvm-opnd (apply-loc instr))
1139                    (gvm-instr-frame instr)
1140                    (gvm-instr-comment instr)))
1141
1142       ((copy)
1143        (make-copy (update-gvm-opnd (copy-opnd instr))
1144                   (update-gvm-opnd (copy-loc instr))
1145                   (gvm-instr-frame instr)
1146                   (gvm-instr-comment instr)))
1147
1148       ((close)
1149        (make-close
1150          (map update-closure-parms (close-parms instr))
1151          (gvm-instr-frame instr)
1152          (gvm-instr-comment instr)))
1153
1154       ((ifjump)
1155        (make-ifjump (ifjump-test instr)
1156                     (map update-gvm-opnd (ifjump-opnds instr))
1157                     (replacement-lbl-num (ifjump-true instr))
1158                     (replacement-lbl-num (ifjump-false instr))
1159                     (ifjump-poll? instr)
1160                     (gvm-instr-frame instr)
1161                     (gvm-instr-comment instr)))
1162
1163       ((switch)
1164        (make-switch (update-gvm-opnd (switch-opnd instr))
1165                     (map (lambda (c)
1166                            (make-switch-case (switch-case-obj c)
1167                                              (replacement-lbl-num
1168                                               (switch-case-lbl c))))
1169                          (switch-cases instr))
1170                     (replacement-lbl-num (switch-default instr))
1171                     (switch-poll? instr)
1172                     (gvm-instr-frame instr)
1173                     (gvm-instr-comment instr)))
1174
1175       ((jump)
1176        (make-jump (update-gvm-opnd (jump-opnd instr))
1177                   (jump-nb-args instr)
1178                   (jump-poll? instr)
1179                   (jump-safe? instr)
1180                   (gvm-instr-frame instr)
1181                   (gvm-instr-comment instr)))
1182
1183       (else
1184        (compiler-internal-error
1185          "update-gvm-instr, unknown 'instr':" instr))))
1186
1187   (bb-non-branch-instrs-set! bb
1188     (map update-gvm-instr (bb-non-branch-instrs bb)))
1189   (bb-branch-instr-set! bb
1190     (update-gvm-instr (bb-branch-instr bb))))
1191
1192 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1193
1194 ;; Step 5, Basic block set ordering:
1195
1196 (define (bbs-order! bbs)
1197
1198   (let ((ordered-blocks (queue-empty))
1199         (left-to-schedule (stretchable-vector-copy (bbs-basic-blocks bbs))))
1200
1201     ; test if a basic block is in 'left-to-schedule' and return the
1202     ; basic block if it is
1203
1204     (define (left-to-schedule? bb)
1205       (stretchable-vector-ref left-to-schedule (bb-lbl-num bb)))
1206
1207     ; remove basic block from 'left-to-schedule'
1208
1209     (define (remove-bb! bb)
1210       (stretchable-vector-set! left-to-schedule (bb-lbl-num bb) #f)
1211       bb)
1212
1213     ; return a basic block which ends with a branch to 'bb' (and that is
1214     ; still in 'left-to-schedule') or #f if there aren't any
1215
1216     (define (prec-bb bb)
1217       (let loop ((lst (bb-precedents bb)) (best #f) (best-fs #f))
1218         (if (null? lst)
1219           best
1220           (let* ((x (car lst))
1221                  (x-fs (bb-exit-frame-size x)))
1222             (if (and (left-to-schedule? x)
1223                      (or (not best) (< x-fs best-fs)))
1224               (loop (cdr lst) x x-fs)
1225               (loop (cdr lst) best best-fs))))))
1226
1227     ; return the basic block which 'bb' jumps to (and that is still in
1228     ; bbs) or #f if there aren't any
1229
1230     (define (succ-bb bb)
1231
1232       (define (branches-to-lbl? bb)
1233         (let ((branch (bb-branch-instr bb)))
1234           (case (gvm-instr-type branch)
1235             ((ifjump) #t)
1236             ((switch) #t)
1237             ((jump) (lbl? (jump-opnd branch)))
1238             (else
1239              (compiler-internal-error
1240               "bbs-order!, unknown branch type")))))
1241
1242       (define (best-succ bb1 bb2)   ; heuristic that determines which
1243         (if (branches-to-lbl? bb1)  ; bb is most frequently executed
1244            bb1
1245            (if (branches-to-lbl? bb2)
1246              bb2
1247              (if (< (bb-exit-frame-size bb1)
1248                     (bb-exit-frame-size bb2))
1249                bb2
1250                bb1))))
1251
1252       (let ((branch (bb-branch-instr bb)))
1253         (case (gvm-instr-type branch)
1254
1255           ((ifjump)
1256            (let* ((true-bb
1257                    (left-to-schedule?
1258                      (lbl-num->bb (ifjump-true branch) bbs)))
1259                   (false-bb
1260                    (left-to-schedule?
1261                      (lbl-num->bb (ifjump-false branch) bbs))))
1262              (if (and true-bb false-bb)
1263                (best-succ true-bb false-bb)
1264                (or true-bb false-bb))))
1265
1266           ((switch)
1267            (left-to-schedule?
1268             (lbl-num->bb (switch-default branch) bbs)))
1269
1270           ((jump)
1271            (let ((opnd (jump-opnd branch)))
1272              (and (lbl? opnd)
1273                   (left-to-schedule?
1274                     (lbl-num->bb (lbl-num opnd) bbs)))))
1275
1276           (else
1277            (compiler-internal-error
1278              "bbs-order!, unknown branch type")))))
1279
1280     ; schedule a given basic block 'bb' with it's predecessors and
1281     ; successors.
1282
1283     (define (schedule-from bb)
1284       (queue-put! ordered-blocks bb)
1285       (let ((x (succ-bb bb)))
1286         (if x
1287           (begin
1288             (schedule-around (remove-bb! x))
1289             (let ((y (succ-bb bb)))
1290               (if y
1291                 (schedule-around (remove-bb! y)))))))
1292       (schedule-refs bb))
1293
1294     (define (schedule-around bb)
1295       (let ((x (prec-bb bb)))
1296         (if x
1297           (let ((bb-list (schedule-back (remove-bb! x) '())))
1298             (queue-put! ordered-blocks x)
1299             (schedule-forw bb)
1300             (for-each schedule-refs bb-list))
1301           (schedule-from bb))))
1302
1303     (define (schedule-back bb bb-list)
1304       (let ((bb-list* (cons bb bb-list))
1305             (x (prec-bb bb)))
1306         (if x
1307           (let ((bb-list (schedule-back (remove-bb! x) bb-list*)))
1308             (queue-put! ordered-blocks x)
1309             bb-list)
1310           bb-list*)))
1311
1312     (define (schedule-forw bb)
1313       (queue-put! ordered-blocks bb)
1314       (let ((x (succ-bb bb)))
1315         (if x
1316           (begin
1317             (schedule-forw (remove-bb! x))
1318             (let ((y (succ-bb bb)))
1319               (if y
1320                 (schedule-around (remove-bb! y)))))))
1321       (schedule-refs bb))
1322
1323     (define (schedule-refs bb)
1324       (for-each
1325         (lambda (x)
1326           (if (left-to-schedule? x)
1327             (schedule-around (remove-bb! x))))
1328         (bb-references bb)))
1329
1330     (schedule-from (remove-bb! (lbl-num->bb (bbs-entry-lbl-num bbs) bbs)))
1331
1332     (let ((basic-blocks (make-stretchable-vector #f))
1333           (lbl-map (make-stretchable-vector #f)))
1334
1335       (define (replacement-lbl-num lbl)
1336         (or (stretchable-vector-ref lbl-map lbl) lbl))
1337
1338       (let loop ((lst (queue->list ordered-blocks)) (i 1))
1339         (if (pair? lst)
1340
1341           (let* ((bb (car lst))
1342                  (label-instr (bb-label-instr bb)))
1343             (stretchable-vector-set! basic-blocks i bb)
1344             (stretchable-vector-set! lbl-map (label-lbl-num label-instr) i)
1345             (label-lbl-num-set! label-instr i)
1346             (loop (cdr lst) (+ i 1)))
1347
1348           (begin
1349
1350             ; Reconstruct bbs
1351
1352             (bbs-next-lbl-num-set! bbs i)
1353
1354             (bbs-basic-blocks-set! bbs basic-blocks)
1355
1356             (bbs-entry-lbl-num-set! bbs
1357               (replacement-lbl-num (bbs-entry-lbl-num bbs)))
1358
1359             (bbs-for-each-bb
1360               (lambda (bb)
1361                 (replace-label-references!
1362                   bb
1363                   replacement-lbl-num))
1364               bbs)))))))
1365
1366 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1367 ;;
1368 ;; Sequentialization of a basic block set:
1369 ;; --------------------------------------
1370
1371 ;; The procedure 'bbs->code-list' transforms a 'purified' basic block set
1372 ;; into a sequence of virtual machine instructions.  Each element of the
1373 ;; resulting list is a 'code' object that contains a GVM instruction,
1374 ;; a pointer to the basic block it came from and a `slots needed' index
1375 ;; that specifies the minimum number of slots that have to be kept (relative
1376 ;; to the start of the frame) after the instruction is executed.
1377 ;; The first element of the code list is the entry label for the piece of code.
1378
1379 (define (make-code bb gvm-instr sn)     (vector bb gvm-instr sn))
1380 (define (code-bb code)                  (vector-ref code 0))
1381 (define (code-gvm-instr code)           (vector-ref code 1))
1382 (define (code-slots-needed code)        (vector-ref code 2))
1383 (define (code-slots-needed-set! code n) (vector-set! code 2 n))
1384
1385 (define (bbs->code-list bbs)
1386   (let ((code-list (linearize bbs)))
1387     (setup-slots-needed! code-list)
1388     code-list))
1389
1390 (define (linearize bbs) ; convert bbs into list of GVM instructions
1391   (let ((code-queue (queue-empty)))
1392
1393     (define (put-bb bb)
1394
1395       (define (put-instr gvm-instr)
1396         (queue-put! code-queue (make-code bb gvm-instr #f)))
1397
1398       (put-instr (bb-label-instr bb))
1399       (for-each put-instr (bb-non-branch-instrs bb))
1400       (put-instr (bb-branch-instr bb)))
1401
1402     (bbs-for-each-bb put-bb bbs)
1403     (queue->list code-queue)))
1404
1405 (define (setup-slots-needed! code-list) ; setup slots-needed field
1406
1407   ; Backward pass to set slots-needed field
1408
1409   (let loop1 ((lst (reverse code-list)) (sn-rest #f))
1410     (if (pair? lst)
1411       (let* ((code (car lst))
1412              (gvm-instr (code-gvm-instr code)))
1413         (loop1
1414          (cdr lst)
1415          (case (gvm-instr-type gvm-instr)
1416
1417            ((label)
1418             (if (> sn-rest (frame-size (gvm-instr-frame gvm-instr)))
1419               (compiler-internal-error
1420                 "setup-slots-needed!, incoherent slots needed for label"))
1421             (code-slots-needed-set! code sn-rest)
1422             #f)
1423
1424            ((ifjump switch jump)
1425             (let ((sn (frame-size (gvm-instr-frame gvm-instr))))
1426               (code-slots-needed-set! code sn)
1427               (need-gvm-instr gvm-instr sn)))
1428
1429            (else
1430             (code-slots-needed-set! code sn-rest)
1431             (need-gvm-instr gvm-instr sn-rest))))))))
1432
1433 (define (need-gvm-instrs non-branch branch)
1434   (if (pair? non-branch)
1435     (need-gvm-instr (car non-branch)
1436                     (need-gvm-instrs (cdr non-branch) branch))
1437     (need-gvm-instr branch
1438                     (frame-size (gvm-instr-frame branch)))))
1439
1440 (define (need-gvm-instr gvm-instr sn-rest)
1441   (case (gvm-instr-type gvm-instr)
1442
1443     ((label)
1444      sn-rest)
1445
1446     ((apply)
1447      (let ((loc (apply-loc gvm-instr)))
1448        (need-gvm-opnds (apply-opnds gvm-instr)
1449          (need-gvm-loc-opnd loc
1450            (need-gvm-loc loc sn-rest)))))
1451
1452     ((copy)
1453      (let ((loc (copy-loc gvm-instr)))
1454        (need-gvm-opnd (copy-opnd gvm-instr)
1455          (need-gvm-loc-opnd loc
1456            (need-gvm-loc loc sn-rest)))))
1457
1458     ((close)
1459      (let ((parms (close-parms gvm-instr)))
1460
1461        (define (need-parms-opnds p)
1462          (if (null? p)
1463            sn-rest
1464            (need-gvm-opnds (closure-parms-opnds (car p))
1465              (need-parms-opnds (cdr p)))))
1466
1467        (define (need-parms-loc p)
1468          (if (null? p)
1469            (need-parms-opnds parms)
1470            (let ((loc (closure-parms-loc (car p))))
1471              (need-gvm-loc-opnd loc
1472                (need-gvm-loc loc (need-parms-loc (cdr p)))))))
1473
1474        (need-parms-loc parms)))
1475
1476     ((ifjump)
1477      (need-gvm-opnds (ifjump-opnds gvm-instr) sn-rest))
1478
1479     ((switch)
1480      (need-gvm-opnd (switch-opnd gvm-instr) sn-rest))
1481
1482     ((jump)
1483      (need-gvm-opnd (jump-opnd gvm-instr) sn-rest))
1484
1485     (else
1486      (compiler-internal-error
1487        "need-gvm-instr, unknown 'gvm-instr':" gvm-instr))))
1488
1489 (define (need-gvm-loc loc sn-rest)
1490   (if (and loc (stk? loc) (>= (stk-num loc) sn-rest))
1491     (- (stk-num loc) 1)
1492     sn-rest))
1493
1494 (define (need-gvm-loc-opnd gvm-loc slots-needed)
1495   (if (and gvm-loc (clo? gvm-loc))
1496     (need-gvm-opnd (clo-base gvm-loc) slots-needed)
1497     slots-needed))
1498
1499 (define (need-gvm-opnd gvm-opnd slots-needed)
1500   (if gvm-opnd
1501     (cond ((stk? gvm-opnd)
1502            (max (stk-num gvm-opnd) slots-needed))
1503           ((clo? gvm-opnd)
1504            (need-gvm-opnd (clo-base gvm-opnd) slots-needed))
1505           (else
1506            slots-needed))
1507     slots-needed))
1508
1509 (define (need-gvm-opnds gvm-opnds slots-needed)
1510   (if (null? gvm-opnds)
1511     slots-needed
1512     (need-gvm-opnd (car gvm-opnds)
1513                    (need-gvm-opnds (cdr gvm-opnds) slots-needed))))
1514
1515 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1516 ;;
1517 ;; Basic block writing:
1518 ;; -------------------
1519
1520 (define (write-bb bb port)
1521   (write-gvm-instr (bb-label-instr bb) port)
1522   (display " [precedents=" port)
1523   (write (map bb-lbl-num (bb-precedents bb)) port)
1524   (display "]" port)
1525   (newline port)
1526
1527   (for-each (lambda (x) (write-gvm-instr x port) (newline port))
1528             (bb-non-branch-instrs bb))
1529
1530   (write-gvm-instr (bb-branch-instr bb) port))
1531
1532 (define (write-bbs bbs port)
1533   (bbs-for-each-bb
1534     (lambda (bb)
1535       (if (= (bb-lbl-num bb) (bbs-entry-lbl-num bbs))
1536         (begin (display "**** Entry block:" port) (newline port)))
1537       (write-bb bb port)
1538       (newline port))
1539     bbs))
1540
1541 (define show-slots-needed? #f)
1542 (set! show-slots-needed? #f)
1543
1544 (define (virtual.dump procs port)
1545
1546   (let ((proc-seen (queue-empty))
1547         (proc-left (queue-empty)))
1548
1549     (define (scan-obj obj)
1550       (if (and (proc-obj? obj)
1551                (proc-obj-code obj)
1552                (not (memq obj (queue->list proc-seen))))
1553         (begin
1554           (queue-put! proc-seen obj)
1555           (queue-put! proc-left obj))))
1556
1557     (define (scan-opnd gvm-opnd)
1558       (cond ((not gvm-opnd))
1559             ((obj? gvm-opnd)
1560              (scan-obj (obj-val gvm-opnd)))
1561             ((clo? gvm-opnd)
1562              (scan-opnd (clo-base gvm-opnd)))))
1563
1564     (define (dump-proc p)
1565
1566       (define (scan-code code)
1567         (let ((gvm-instr (code-gvm-instr code)))
1568
1569           (if show-slots-needed?
1570             (begin
1571               (display "sn=" port)
1572               (display (code-slots-needed code) port)
1573               (display " | " port)))
1574
1575           (write-gvm-instr gvm-instr port)
1576           (newline port)
1577           (case (gvm-instr-type gvm-instr)
1578
1579             ((apply)
1580              (for-each scan-opnd (apply-opnds gvm-instr))
1581              (if (apply-loc gvm-instr)
1582                (scan-opnd (apply-loc gvm-instr))))
1583
1584             ((copy)
1585              (scan-opnd (copy-opnd gvm-instr))
1586              (scan-opnd (copy-loc gvm-instr)))
1587
1588             ((close)
1589              (for-each (lambda (parms)
1590                          (scan-opnd (closure-parms-loc parms))
1591                          (for-each scan-opnd (closure-parms-opnds parms)))
1592                        (close-parms gvm-instr)))
1593
1594             ((ifjump)
1595              (for-each scan-opnd (ifjump-opnds gvm-instr)))
1596
1597             ((switch)
1598              (scan-opnd (switch-opnd gvm-instr))
1599              (for-each (lambda (c) (scan-obj (switch-case-obj c)))
1600                        (switch-cases gvm-instr)))
1601
1602             ((jump)
1603              (scan-opnd (jump-opnd gvm-instr)))
1604
1605             (else
1606              '()))))
1607
1608       (if (proc-obj-primitive? p)
1609         (display "**** #<primitive " port)
1610         (display "**** #<procedure " port))
1611       (write (string->canonical-symbol (proc-obj-name p)) port)
1612       (display "> =" port)
1613       (newline port)
1614
1615       (let ((x (proc-obj-code p)))
1616         (if (bbs? x)
1617
1618           (let loop ((l (bbs->code-list x))
1619                      (prev-filename "")
1620                      (prev-line 0))
1621             (if (pair? l)
1622               (let* ((code (car l))
1623                      (instr (code-gvm-instr code))
1624                      (node (comment-get (gvm-instr-comment instr) 'node))
1625                      (src (node-source node))
1626                      (loc (and src (source-locat src)))
1627                      (filename
1628                        (if (and loc (string? (vector-ref loc 0)));;;;;;;;;;;;;
1629                          (vector-ref loc 0)
1630                          prev-filename))
1631                      (line
1632                        (if (and loc (string? (vector-ref loc 0)))
1633                          (+ (**filepos-line (vector-ref loc 1)) 1)
1634                          prev-line)))
1635                 (if (or (not (string=? filename prev-filename))
1636                         (not (= line prev-line)))
1637                   (begin
1638                     (display "#line " port)
1639                     (display line port)
1640                     (if (not (string=? filename prev-filename))
1641                       (begin
1642                         (display " " port)
1643                         (write filename port)))
1644                     (newline port)))
1645
1646                 (scan-code code)
1647                 (loop (cdr l) filename line))
1648               (newline port)))
1649
1650           (begin
1651             (display "C procedure of arity " port)
1652             (display (c-proc-arity x) port)
1653             (display " and body:" port)
1654             (newline port)
1655             (display (c-proc-body x) port)
1656             (newline port)))))
1657
1658     (for-each (lambda (proc) (scan-opnd (make-obj proc))) procs)
1659
1660     (let loop ()
1661       (if (not (queue-empty? proc-left))
1662         (begin
1663           (dump-proc (queue-get! proc-left))
1664           (loop))))))
1665
1666 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1667 ;;
1668 ;; Virtual instruction writing:
1669 ;; ---------------------------
1670
1671 (define (write-gvm-instr gvm-instr port)
1672
1673   (define (write-closure-parms parms)
1674     (display " " port)
1675     (let ((len (+ 1 (write-gvm-opnd (closure-parms-loc parms) port))))
1676       (display " = (" port)
1677       (let ((len (+ len (+ 4 (write-gvm-lbl (closure-parms-lbl parms) port)))))
1678         (+ len (write-spaced-opnd-list (closure-parms-opnds parms) port)))))
1679
1680   (define (write-spaced-opnd-list l port)
1681     (let loop ((l l) (len 0))
1682       (if (pair? l)
1683         (let ((opnd (car l)))
1684           (display " " port)
1685           (loop (cdr l) (+ len (+ 1 (write-gvm-opnd opnd port)))))
1686         (begin
1687           (display ")" port)
1688           (+ len 1)))))
1689
1690   (define (write-opnd-list l port)
1691     (if (pair? l)
1692       (let ((len (write-gvm-opnd (car l) port)))
1693         (+ len (write-spaced-opnd-list (cdr l) port)))
1694       (begin
1695         (display ")" port)
1696         1)))
1697
1698   (define (write-key-pair-list keys port)
1699     (if keys
1700       (begin
1701         (display " (" port)
1702         (if (pair? keys)
1703           (let loop ((l keys))
1704             (let* ((key-pair (car l))
1705                    (key (car key-pair))
1706                    (opnd (cdr key-pair))
1707                    (rest (cdr l)))
1708               (display "(" port)
1709               (let ((len (+ 1 (write-returning-len key port))))
1710                 (display " " port)
1711                 (let ((len (+ len (+ 1 (write-gvm-opnd opnd port)))))
1712                   (display ")" port)
1713                   (if (pair? rest)
1714                     (begin
1715                       (display " " port)
1716                       (+ len (+ 2 (loop rest))))
1717                     (begin
1718                       (display ")" port)
1719                       (+ len 4)))))))
1720           (begin
1721             (display ")" port)
1722             3)))
1723       0))
1724
1725   (define (write-param-pattern gvm-instr port)
1726     (let ((len (write-returning-len
1727                  (label-entry-nb-parms gvm-instr)
1728                  port)))
1729       (display " (" port)
1730       (let ((len (+ len
1731                     (+ 2
1732                        (write-opnd-list
1733                          (label-entry-opts gvm-instr)
1734                          port)))))
1735         (let ((len (+ len
1736                       (write-key-pair-list
1737                         (label-entry-keys gvm-instr)
1738                         port))))
1739           (if (label-entry-rest? gvm-instr)
1740             (begin (display " +" port) (+ len 2))
1741             len)))))
1742
1743   (define (write-prim-applic prim opnds port)
1744     (display "(" port)
1745     (let ((len (+ 1 (display-returning-len (proc-obj-name prim) port))))
1746       (+ len (write-spaced-opnd-list opnds port))))
1747
1748   (define (write-instr gvm-instr)
1749     (case (gvm-instr-type gvm-instr)
1750
1751       ((label)
1752        (let ((len (write-gvm-lbl (label-lbl-num gvm-instr) port)))
1753          (display " " port)
1754          (let ((len (+ len
1755                        (+ 1 (write-returning-len
1756                               (frame-size (gvm-instr-frame gvm-instr))
1757                               port)))))
1758            (case (label-type gvm-instr)
1759              ((simple)
1760               len)
1761              ((entry)
1762               (if (label-entry-closed? gvm-instr)
1763                 (begin
1764                   (display " closure-entry-point " port)
1765                   (+ len (+ 21 (write-param-pattern gvm-instr port))))
1766                 (begin
1767                   (display " entry-point " port)
1768                   (+ len (+ 13 (write-param-pattern gvm-instr port))))))
1769              ((return)
1770               (display " return-point" port)
1771               (+ len 13))
1772              ((task-entry)
1773               (display " task-entry-point" port)
1774               (+ len 17))
1775              ((task-return)
1776               (display " task-return-point" port)
1777               (+ len 18))
1778              (else
1779               (compiler-internal-error
1780                 "write-gvm-instr, unknown label type"))))))
1781
1782       ((apply)
1783        (display "  " port)
1784        (let ((len (+ 2 (write-gvm-opnd (apply-loc gvm-instr) port))))
1785          (display " = " port)
1786          (+ len
1787             (+ 3
1788                (write-prim-applic (apply-prim gvm-instr)
1789                                   (apply-opnds gvm-instr)
1790                                   port)))))
1791
1792       ((copy)
1793        (display "  " port)
1794        (let ((len (+ 2 (write-gvm-opnd (copy-loc gvm-instr) port))))
1795          (display " = " port)
1796          (+ len (+ 3 (write-gvm-opnd (copy-opnd gvm-instr) port)))))
1797
1798       ((close)
1799        (display "  close" port)
1800        (let ((len (+ 7 (write-closure-parms (car (close-parms gvm-instr))))))
1801          (let loop ((l (cdr (close-parms gvm-instr))) (len len))
1802            (if (pair? l)
1803              (let ((x (car l)))
1804                (display "," port)
1805                (loop (cdr l) (+ len (+ 1 (write-closure-parms x)))))
1806              len))))
1807
1808       ((ifjump)
1809        (display "  if " port)
1810        (let ((len (+ 5
1811                      (write-prim-applic (ifjump-test gvm-instr)
1812                                         (ifjump-opnds gvm-instr)
1813                                         port))))
1814          (let ((len (+ len
1815                        (if (ifjump-poll? gvm-instr)
1816                          (begin (display " jump* " port) 7)
1817                          (begin (display " jump " port) 6)))))
1818            (let ((len (+ len
1819                          (write-returning-len
1820                            (frame-size (gvm-instr-frame gvm-instr))
1821                            port))))
1822              (display " " port)
1823              (let ((len (+ len
1824                            (+ 1 (write-gvm-lbl
1825                                   (ifjump-true gvm-instr)
1826                                   port)))))
1827                (display " else " port)
1828                (+ len (+ 6 (write-gvm-lbl
1829                              (ifjump-false gvm-instr)
1830                              port))))))))
1831
1832       ((switch)
1833        (display "  " port)
1834        (let ((len (+ 2
1835                      (if (switch-poll? gvm-instr)
1836                        (begin (display "switch* " port) 8)
1837                        (begin (display "switch " port) 7)))))
1838          (let ((len (+ len
1839                        (write-returning-len
1840                         (frame-size (gvm-instr-frame gvm-instr))
1841                         port))))
1842            (display " " port)
1843            (let ((len (+ len
1844                          (+ 1 (write-gvm-opnd (switch-opnd gvm-instr) port)))))
1845              (display " (" port)
1846              (let ((len
1847                     (let loop ((cases (switch-cases gvm-instr))
1848                                (len (+ len 2)))
1849                       (if (pair? cases)
1850                         (let ((c (car cases)))
1851                           (let ((len (+ len
1852                                         (write-gvm-obj (switch-case-obj c)
1853                                                        port))))
1854                             (display " => " port)
1855                             (let ((len (+ len
1856                                           (+ 4 (write-gvm-lbl (switch-case-lbl c)
1857                                                               port)))))
1858                               (let ((next (cdr cases)))
1859                                 (if (null? next)
1860                                   len
1861                                   (begin
1862                                     (display ", " port)
1863                                     (loop next (+ len 2))))))))
1864                         len))))
1865                (display ") " port)
1866                (+ len
1867                   (+ 2 (write-gvm-lbl
1868                         (switch-default gvm-instr)
1869                         port))))))))
1870
1871       ((jump)
1872        (display "  " port)
1873        (let ((len (+ 2
1874                      (if (jump-poll? gvm-instr)
1875                        (begin (display "jump*" port) 5)
1876                        (begin (display "jump" port) 4)))))
1877          (let ((len (+ len
1878                        (if (jump-safe? gvm-instr)
1879                          (begin (display "$ " port) 2)
1880                          (begin (display " " port) 1)))))
1881            (let ((len (+ len
1882                          (write-returning-len
1883                            (frame-size (gvm-instr-frame gvm-instr))
1884                            port))))
1885              (display " " port)
1886              (let ((len (+ len
1887                            (+ 1 (write-gvm-opnd (jump-opnd gvm-instr) port)))))
1888                (+ len
1889                   (if (jump-nb-args gvm-instr)
1890                     (begin
1891                       (display " " port)
1892                       (+ 1 (write-returning-len
1893                              (jump-nb-args gvm-instr)
1894                              port)))
1895                     0)))))))
1896
1897       (else
1898        (compiler-internal-error
1899          "write-gvm-instr, unknown 'gvm-instr':"
1900          gvm-instr))))
1901
1902   (define (spaces n)
1903     (if (> n 0)
1904       (if (> n 7)
1905         (begin (display "        " port) (spaces (- n 8)))
1906         (begin (display " " port) (spaces (- n 1))))))
1907
1908   (let ((len (write-instr gvm-instr)))
1909     (spaces (- 43 len))
1910     (display " " port)
1911     (write-frame (gvm-instr-frame gvm-instr) port))
1912
1913   (let ((x (gvm-instr-comment gvm-instr)))
1914     (if x
1915       (let ((y (comment-get x 'text)))
1916         (if y
1917           (begin
1918             (display " ; " port)
1919             (display y port)))))))
1920
1921 (define (write-frame frame port)
1922
1923   (define (write-var var opnd sep)
1924     (display sep port)
1925     (write-gvm-opnd opnd port)
1926     (if var
1927       (begin
1928         (display "=" port)
1929         (cond ((eq? var closure-env-var)
1930                (write (map (lambda (var) (var-name var)) (frame-closed frame))
1931                       port))
1932               ((eq? var ret-var)
1933                (display "#" port))
1934               ((temp-var? var)
1935                (display "." port))
1936               (else
1937                (write (var-name var) port))))))
1938
1939   (define (live? var)
1940     (let ((live (frame-live frame)))
1941       (or (varset-member? var live)
1942           (and (eq? var closure-env-var)
1943                (varset-intersects?
1944                  live
1945                  (list->varset (frame-closed frame)))))))
1946
1947   (let loop1 ((i 1) (l (reverse (frame-slots frame))) (sep "; "))
1948     (if (pair? l)
1949       (let ((var (car l)))
1950         (write-var (if (live? var) var #f) (make-stk i) sep)
1951         (loop1 (+ i 1) (cdr l) " "))
1952       (let loop2 ((i 0) (l (frame-regs frame)) (sep sep))
1953         (if (pair? l)
1954           (let ((var (car l)))
1955             (if (live? var)
1956               (begin
1957                 (write-var var (make-reg i) sep)
1958                 (loop2 (+ i 1) (cdr l) " "))
1959               (loop2 (+ i 1) (cdr l) sep))))))))
1960
1961 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1962 ;;
1963 ;; Operand writing:
1964 ;; ---------------
1965
1966 (define (write-gvm-opnd gvm-opnd port)
1967   (cond ((not gvm-opnd)
1968          (display "." port)
1969          1)
1970         ((reg? gvm-opnd)
1971          (display "+" port)
1972          (+ 1 (write-returning-len (reg-num gvm-opnd) port)))
1973         ((stk? gvm-opnd)
1974          (display "-" port)
1975          (+ 1 (write-returning-len (stk-num gvm-opnd) port)))
1976         ((glo? gvm-opnd)
1977          (write-returning-len (glo-name gvm-opnd) port))
1978         ((clo? gvm-opnd)
1979          (let ((len (write-gvm-opnd (clo-base gvm-opnd) port)))
1980            (display "(" port)
1981            (let ((len (+ len
1982                          (+ 1 (write-returning-len
1983                                 (clo-index gvm-opnd)
1984                                 port)))))
1985              (display ")" port)
1986              (+ len 1))))
1987         ((lbl? gvm-opnd)
1988          (write-gvm-lbl (lbl-num gvm-opnd) port))
1989         ((obj? gvm-opnd)
1990          (display "'" port)
1991          (+ (write-gvm-obj (obj-val gvm-opnd) port) 1))
1992         (else
1993          (compiler-internal-error
1994            "write-gvm-opnd, unknown 'gvm-opnd':"
1995            gvm-opnd))))
1996
1997 (define (write-gvm-lbl lbl port)
1998   (display "#" port)
1999   (+ (write-returning-len lbl port) 1))
2000
2001 (define (write-gvm-obj val port)
2002   (cond ((proc-obj? val)
2003          (if (proc-obj-primitive? val)
2004            (display "#<primitive " port)
2005            (display "#<procedure " port))
2006          (let ((len
2007                 (write-returning-len
2008                   (string->canonical-symbol (proc-obj-name val))
2009                   port)))
2010            (display ">" port)
2011            (+ len 13)))
2012         (else
2013          (write-returning-len val port))))
2014
2015 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2016
2017 (define (virtual.begin!) ; initialize module
2018   (set! *opnd-table* '#())
2019   (set! *opnd-table-alloc* 0)
2020   '())
2021
2022 (define (virtual.end!) ; finalize module
2023   (set! *opnd-table* '())
2024   '())
2025
2026 ;;;============================================================================