Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

2036 lines (1715 sloc) 74.323 kb
;;;============================================================================
;;; File: "_gvm.scm"
;;; Copyright (c) 1994-2012 by Marc Feeley, All Rights Reserved.
(include "fixnum.scm")
(include-adt "_envadt.scm")
(include "_gvmadt.scm")
(include-adt "_ptreeadt.scm")
(include-adt "_sourceadt.scm")
;;;----------------------------------------------------------------------------
;;
;; Gambit virtual machine abstraction module:
;; -----------------------------------------
;; (See file 'doc/gvm' for details on the virtual machine)
;; Utilities:
;; ---------
(define *opnd-table* #f)
(define *opnd-table-alloc* #f)
(define (extend-opnd-table!)
(let* ((n (vector-length *opnd-table*))
(new-table (make-vector (+ (quotient (* 3 n) 2) 1) #f)))
(let loop ((i 0))
(if (< i n)
(begin
(vector-set! new-table i (vector-ref *opnd-table* i))
(loop (+ i 1)))
(set! *opnd-table* new-table)))))
(define (enter-opnd arg1 arg2)
(let loop ((i 0))
(if (< i *opnd-table-alloc*)
(let ((x (vector-ref *opnd-table* i)))
(if (and (eqv? (car x) arg1) (eqv? (cdr x) arg2))
i
(loop (+ i 1))))
(begin
(set! *opnd-table-alloc* (+ *opnd-table-alloc* 1))
(if (> *opnd-table-alloc* (vector-length *opnd-table*))
(extend-opnd-table!))
(vector-set! *opnd-table* i (cons arg1 arg2))
i))))
(define (contains-opnd? opnd1 opnd2) ; does opnd2 contain opnd1?
(cond ((eqv? opnd1 opnd2)
#t)
((clo? opnd2)
(contains-opnd? opnd1 (clo-base opnd2)))
(else
#f)))
(define (any-contains-opnd? opnd opnds)
(if (null? opnds)
#f
(or (contains-opnd? opnd (car opnds))
(any-contains-opnd? opnd (cdr opnds)))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;
;; Processor context descriptions:
;; ------------------------------
(define (make-pcontext fs map)
(vector fs map))
(define (pcontext-fs x) (vector-ref x 0))
(define (pcontext-map x) (vector-ref x 1))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;
;; Frame description:
;; -----------------
(define (make-frame size slots regs closed live)
(vector size slots regs closed live))
(define (frame-size x) (vector-ref x 0))
(define (frame-slots x) (vector-ref x 1))
(define (frame-regs x) (vector-ref x 2))
(define (frame-closed x) (vector-ref x 3))
(define (frame-live x) (vector-ref x 4))
(define (frame-eq? frame1 frame2)
; two frames are "equal" if they have the same number of slots and
; for all slots and registers in a frame the corresponding slot or
; register in the other frame has the same liveness and the return
; address is in the same place.
(define (same-liveness? var1 var2)
(eq? (varset-member? var1 (frame-live frame1))
(varset-member? var2 (frame-live frame2))))
(define (same-liveness-list? lst1 lst2)
(if (pair? lst1)
(let ((var1 (car lst1)))
(if (pair? lst2)
(let ((var2 (car lst2)))
(and (eq? (eq? var1 ret-var) (eq? var2 ret-var))
(same-liveness? var1 var2)
(same-liveness-list? (cdr lst1) (cdr lst2))))
(and (same-liveness? var1 empty-var)
(same-liveness-list? (cdr lst1) lst2))))
(if (pair? lst2)
(let ((var2 (car lst2)))
(and (same-liveness? empty-var var2)
(same-liveness-list? lst1 (cdr lst2))))
#t)))
(and (= (frame-size frame1) (frame-size frame2))
(let ((slots1 (frame-slots frame1))
(slots2 (frame-slots frame2)))
(same-liveness-list? slots1 slots2))
(let ((regs1 (frame-regs frame1))
(regs2 (frame-regs frame2)))
(same-liveness-list? regs1 regs2))))
(define (frame-truncate frame nb-slots)
(let ((fs (frame-size frame)))
(make-frame nb-slots
(drop (frame-slots frame) (- fs nb-slots))
(frame-regs frame)
(frame-closed frame)
(frame-live frame))))
(define (frame-live? var frame)
(let ((live (frame-live frame)))
(if (eq? var closure-env-var)
(let ((closed (frame-closed frame)))
(if (or (varset-member? var live)
(varset-intersects? live (list->varset closed)))
closed
#f))
(if (varset-member? var live)
var
#f))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;
;; Procedure objects:
;; -----------------
(define (make-proc-obj
name
c-name
primitive?
code
call-pat
side-effects?
strict-pat
lift-pat
type
standard)
(let ((proc-obj
(vector
proc-obj-tag
name
c-name
primitive?
code
call-pat
(lambda (env) #f) ; testable?
#f ; test
(lambda (env) #f) ; expandable?
#f ; expand
(lambda (env) #f) ; inlinable?
#f ; inline
(lambda (env) #f) ; jump-inlinable?
#f ; jump-inline
#f ; specialize
#f ; simplify
side-effects?
strict-pat
lift-pat
type
standard)))
(proc-obj-specialize-set! proc-obj (lambda (env args) proc-obj))
proc-obj))
(define proc-obj-tag (list 'proc-obj))
(define (proc-obj? x)
(and (vector? x)
(> (vector-length x) 0)
(eq? (vector-ref x 0) proc-obj-tag)))
(define (proc-obj-name obj) (vector-ref obj 1))
(define (proc-obj-c-name obj) (vector-ref obj 2))
(define (proc-obj-primitive? obj) (vector-ref obj 3))
(define (proc-obj-code obj) (vector-ref obj 4))
(define (proc-obj-call-pat obj) (vector-ref obj 5))
(define (proc-obj-testable? obj) (vector-ref obj 6))
(define (proc-obj-test obj) (vector-ref obj 7))
(define (proc-obj-expandable? obj) (vector-ref obj 8))
(define (proc-obj-expand obj) (vector-ref obj 9))
(define (proc-obj-inlinable? obj) (vector-ref obj 10))
(define (proc-obj-inline obj) (vector-ref obj 11))
(define (proc-obj-jump-inlinable? obj) (vector-ref obj 12))
(define (proc-obj-jump-inline obj) (vector-ref obj 13))
(define (proc-obj-specialize obj) (vector-ref obj 14))
(define (proc-obj-simplify obj) (vector-ref obj 15))
(define (proc-obj-side-effects? obj) (vector-ref obj 16))
(define (proc-obj-strict-pat obj) (vector-ref obj 17))
(define (proc-obj-lift-pat obj) (vector-ref obj 18))
(define (proc-obj-type obj) (vector-ref obj 19))
(define (proc-obj-standard obj) (vector-ref obj 20))
(define (proc-obj-code-set! obj x) (vector-set! obj 4 x))
(define (proc-obj-testable?-set! obj x) (vector-set! obj 6 x))
(define (proc-obj-test-set! obj x) (vector-set! obj 7 x))
(define (proc-obj-expandable?-set! obj x) (vector-set! obj 8 x))
(define (proc-obj-expand-set! obj x) (vector-set! obj 9 x))
(define (proc-obj-inlinable?-set! obj x) (vector-set! obj 10 x))
(define (proc-obj-inline-set! obj x) (vector-set! obj 11 x))
(define (proc-obj-jump-inlinable?-set! obj x) (vector-set! obj 12 x))
(define (proc-obj-jump-inline-set! obj x) (vector-set! obj 13 x))
(define (proc-obj-specialize-set! obj x) (vector-set! obj 14 x))
(define (proc-obj-simplify-set! obj x) (vector-set! obj 15 x))
(define (make-pattern nb-parms nb-opts nb-keys rest?)
(let* ((max-pos-args (- nb-parms nb-keys (if rest? 1 0)))
(min-args (- max-pos-args nb-opts)))
(let loop ((i
(- max-pos-args 1))
(pattern
(if (or (> nb-keys 0) rest?)
max-pos-args
(list max-pos-args))))
(if (>= i min-args)
(loop (- i 1) (cons i pattern))
pattern))))
(define (pattern-member? n pat) ; tests if 'n' is a member of pattern 'pat'
(cond ((pair? pat)
(if (= (car pat) n) #t (pattern-member? n (cdr pat))))
((null? pat)
#f)
(else
(<= pat n))))
(define (type-name type)
(if (pair? type) (car type) type))
(define (type-pot-fut? type)
(pair? type))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;
;; Basic block set manipulation:
;; ----------------------------
;; Virtual instructions have a linear structure. However, this is not
;; how they are put together to form a piece of code. Rather, virtual
;; instructions are grouped into 'basic blocks' which are 'linked'
;; together. A basic block is a 'label' instruction followed by a
;; sequence of non-branching instructions (i.e. 'apply', 'copy' or
;; 'close') terminated by a single branch instruction (i.e. 'ifjump',
;; 'jump' or 'switch'). Links between basic blocks are denoted using
;; label references. When a basic block ends with an 'ifjump'
;; instruction, the block is linked to the two basic blocks
;; corresponding to the two possible control paths out of the 'ifjump'
;; instruction. When a basic block ends with a 'switch' instruction, the
;; block is linked to as many basic blocks as there are cases and the
;; default. When a basic block ends with a 'jump' instruction, there
;; is either zero or one link.
;;
;; Basic blocks naturally group together to form 'basic block sets'. A
;; basic block set describes all the code of a procedure.
(define (make-bbs)
(vector bbs-tag
1 ; 1 - next assignable label number
(make-stretchable-vector #f) ; 2 - vector of basic blocks
#f)) ; 3 - entry label number
(define bbs-tag (list 'bbs))
(define (bbs? x)
(and (vector? x)
(> (vector-length x) 0)
(eq? (vector-ref x 0) bbs-tag)))
(define (bbs-next-lbl-num bbs) (vector-ref bbs 1))
(define (bbs-next-lbl-num-set! bbs lbl-num) (vector-set! bbs 1 lbl-num))
(define (bbs-basic-blocks bbs) (vector-ref bbs 2))
(define (bbs-basic-blocks-set! bbs blocks) (vector-set! bbs 2 blocks))
(define (bbs-entry-lbl-num bbs) (vector-ref bbs 3))
(define (bbs-entry-lbl-num-set! bbs lbl-num) (vector-set! bbs 3 lbl-num))
(define (bbs-for-each-bb proc bbs)
(stretchable-vector-for-each
(lambda (bb i) (if bb (proc bb)))
(bbs-basic-blocks bbs)))
(define (bbs-bb-remove! bbs lbl)
(stretchable-vector-set! (bbs-basic-blocks bbs) lbl #f))
(define (bbs-new-lbl! bbs)
(let ((n (bbs-next-lbl-num bbs)))
(bbs-next-lbl-num-set! bbs (+ n 1))
n))
(define (lbl-num->bb lbl-num bbs)
(stretchable-vector-ref (bbs-basic-blocks bbs) lbl-num))
;; Basic block manipulation procedures:
(define (make-bb label-instr bbs)
(let ((bb (vector
label-instr ; 0 - 'label' instr
(queue-empty) ; 1 - sequence of non-branching instrs
'() ; 2 - branch instruction
'() ; 3 - basic blocks referenced by this block
'()))) ; 4 - basic blocks which jump to this block
; (both filled in by 'bbs-purify!')
(stretchable-vector-set!
(bbs-basic-blocks bbs)
(label-lbl-num label-instr)
bb)
bb))
(define (bb-lbl-num bb) (label-lbl-num (vector-ref bb 0)))
(define (bb-label-type bb) (label-type (vector-ref bb 0)))
(define (bb-label-instr bb) (vector-ref bb 0))
(define (bb-label-instr-set! bb l) (vector-set! bb 0 l))
(define (bb-non-branch-instrs bb) (queue->list (vector-ref bb 1)))
(define (bb-non-branch-instrs-set! bb l) (vector-set! bb 1 (list->queue l)))
(define (bb-branch-instr bb) (vector-ref bb 2))
(define (bb-branch-instr-set! bb b) (vector-set! bb 2 b))
(define (bb-references bb) (vector-ref bb 3))
(define (bb-references-set! bb l) (vector-set! bb 3 l))
(define (bb-precedents bb) (vector-ref bb 4))
(define (bb-precedents-set! bb l) (vector-set! bb 4 l))
(define (bb-entry-frame-size bb)
(frame-size (gvm-instr-frame (bb-label-instr bb))))
(define (bb-exit-frame-size bb)
(frame-size (gvm-instr-frame (bb-branch-instr bb))))
(define (bb-slots-gained bb)
(- (bb-exit-frame-size bb) (bb-entry-frame-size bb)))
(define (bb-put-non-branch! bb gvm-instr)
(queue-put! (vector-ref bb 1) gvm-instr))
(define (bb-put-branch! bb gvm-instr)
(vector-set! bb 2 gvm-instr))
(define (bb-add-reference! bb ref)
(if (not (memq ref (vector-ref bb 3)))
(vector-set! bb 3 (cons ref (vector-ref bb 3)))))
(define (bb-add-precedent! bb prec)
(if (not (memq prec (vector-ref bb 4)))
(vector-set! bb 4 (cons prec (vector-ref bb 4)))))
(define (bb-last-non-branch-instr bb)
(let ((non-branch-instrs (bb-non-branch-instrs bb)))
(if (null? non-branch-instrs)
(bb-label-instr bb)
(let loop ((l non-branch-instrs))
(if (pair? (cdr l))
(loop (cdr l))
(car l))))))
;; Virtual machine instruction representation:
(define (gvm-instr-type gvm-instr) (vector-ref gvm-instr 0))
(define (gvm-instr-frame gvm-instr) (vector-ref gvm-instr 1))
(define (gvm-instr-comment gvm-instr) (vector-ref gvm-instr 2))
(define (make-label-simple lbl-num frame comment)
(vector 'label frame comment lbl-num 'simple))
(define (make-label-entry lbl-num nb-parms opts keys rest? closed? frame comment)
(vector 'label frame comment lbl-num 'entry nb-parms opts keys rest? closed?))
(define (make-label-return lbl-num frame comment)
(vector 'label frame comment lbl-num 'return))
(define (make-label-task-entry lbl-num frame comment)
(vector 'label frame comment lbl-num 'task-entry))
(define (make-label-task-return lbl-num frame comment)
(vector 'label frame comment lbl-num 'task-return))
(define (label-lbl-num gvm-instr) (vector-ref gvm-instr 3))
(define (label-lbl-num-set! gvm-instr n) (vector-set! gvm-instr 3 n))
(define (label-type gvm-instr) (vector-ref gvm-instr 4))
(define (label-entry-nb-parms gvm-instr) (vector-ref gvm-instr 5))
(define (label-entry-opts gvm-instr) (vector-ref gvm-instr 6))
(define (label-entry-keys gvm-instr) (vector-ref gvm-instr 7))
(define (label-entry-rest? gvm-instr) (vector-ref gvm-instr 8))
(define (label-entry-closed? gvm-instr) (vector-ref gvm-instr 9))
(define (make-apply prim opnds loc frame comment)
(vector 'apply frame comment prim opnds loc))
(define (apply-prim gvm-instr) (vector-ref gvm-instr 3))
(define (apply-opnds gvm-instr) (vector-ref gvm-instr 4))
(define (apply-loc gvm-instr) (vector-ref gvm-instr 5))
(define (make-copy opnd loc frame comment)
(vector 'copy frame comment opnd loc))
(define (copy-opnd gvm-instr) (vector-ref gvm-instr 3))
(define (copy-loc gvm-instr) (vector-ref gvm-instr 4))
(define (make-close parms frame comment)
(vector 'close frame comment parms))
(define (close-parms gvm-instr) (vector-ref gvm-instr 3))
(define (make-closure-parms loc lbl opnds)
(vector loc lbl opnds))
(define (closure-parms-loc x) (vector-ref x 0))
(define (closure-parms-lbl x) (vector-ref x 1))
(define (closure-parms-opnds x) (vector-ref x 2))
(define (make-ifjump test opnds true false poll? frame comment)
(vector 'ifjump frame comment test opnds true false poll?))
(define (ifjump-test gvm-instr) (vector-ref gvm-instr 3))
(define (ifjump-opnds gvm-instr) (vector-ref gvm-instr 4))
(define (ifjump-true gvm-instr) (vector-ref gvm-instr 5))
(define (ifjump-false gvm-instr) (vector-ref gvm-instr 6))
(define (ifjump-poll? gvm-instr) (vector-ref gvm-instr 7))
(define (make-switch opnd cases default poll? frame comment)
(vector 'switch frame comment opnd cases default poll?))
(define (switch-opnd gvm-instr) (vector-ref gvm-instr 3))
(define (switch-cases gvm-instr) (vector-ref gvm-instr 4))
(define (switch-default gvm-instr) (vector-ref gvm-instr 5))
(define (switch-poll? gvm-instr) (vector-ref gvm-instr 6))
(define (make-switch-case obj lbl) (cons obj lbl))
(define (switch-case-obj switch-case) (car switch-case))
(define (switch-case-lbl switch-case) (cdr switch-case))
(define (make-jump opnd nb-args poll? safe? frame comment)
(vector 'jump frame comment opnd nb-args poll? safe?))
(define (jump-opnd gvm-instr) (vector-ref gvm-instr 3))
(define (jump-nb-args gvm-instr) (vector-ref gvm-instr 4))
(define (jump-poll? gvm-instr) (vector-ref gvm-instr 5))
(define (jump-safe? gvm-instr) (vector-ref gvm-instr 6))
(define (first-class-jump? gvm-instr) (jump-nb-args gvm-instr))
(define (make-comment)
(cons 'comment '()))
(define (comment-put! comment name val)
(set-cdr! comment (cons (cons name val) (cdr comment))))
(define (comment-get comment name)
(and comment
(let ((x (assq name (cdr comment))))
(if x (cdr x) #f))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;
;; 'Purification' of basic block sets:
;; ----------------------------------
;; This step removes unreachable basic blocks (i.e. dead code), duplicate
;; basic blocks (i.e. common code), useless jumps and jump cascades from
;; a basic block set. It also orders the basic blocks so that the destination
;; of a branch is put (if possible) right after the branch instruction. The
;; 'references' and 'precedents' fields of each basic block are also filled in
;; through the process. The first basic block of a 'purified' basic block set
;; is always the entry point.
(define (bbs-purify! bbs)
(let loop () ; iterate until code does not change
(bbs-remove-jump-cascades! bbs)
(bbs-remove-dead-code! bbs)
(let* ((changed1? (bbs-remove-common-code! bbs))
(changed2? (bbs-remove-useless-jumps! bbs)))
(if (or changed1? changed2?) (loop) (bbs-order! bbs)))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;; Step 1, Jump cascade removal:
(define (bbs-remove-jump-cascades! bbs)
(define (empty-bb? bb)
(and (eq? (bb-label-type bb) 'simple) ; simple label and
(null? (bb-non-branch-instrs bb)))) ; no non-branching instrs
(define (jump-to-non-entry-lbl? branch)
(and (eq? (gvm-instr-type branch) 'jump)
(not (first-class-jump? branch)) ; not a jump to an entry label
(jump-lbl? branch)))
(define (jump-cascade-to lbl-num fs poll? seen thunk)
(if (memq lbl-num seen) ; infinite loop?
(thunk lbl-num fs poll?)
(let ((bb (lbl-num->bb lbl-num bbs)))
(if (and (empty-bb? bb) (<= (bb-slots-gained bb) 0))
(let ((jump-lbl-num
(jump-to-non-entry-lbl? (bb-branch-instr bb))))
(if jump-lbl-num
(jump-cascade-to
jump-lbl-num
(+ fs (bb-slots-gained bb))
(or poll? (jump-poll? (bb-branch-instr bb)))
(cons lbl-num seen)
thunk)
(thunk lbl-num fs poll?)))
(thunk lbl-num fs poll?)))))
(define (equiv-lbl lbl-num seen)
(if (memq lbl-num seen) ; infinite loop?
lbl-num
(let ((bb (lbl-num->bb lbl-num bbs)))
(if (empty-bb? bb)
(let ((jump-lbl-num
(jump-to-non-entry-lbl? (bb-branch-instr bb))))
(if (and jump-lbl-num
(not (jump-poll? (bb-branch-instr bb)))
(= (bb-slots-gained bb) 0))
(equiv-lbl jump-lbl-num (cons lbl-num seen))
lbl-num))
lbl-num))))
(define (remove-cascade! bb)
(let ((branch (bb-branch-instr bb)))
(case (gvm-instr-type branch)
((ifjump) ; branch is an 'ifjump'
(bb-put-branch! bb
(make-ifjump (ifjump-test branch)
(ifjump-opnds branch)
(equiv-lbl (ifjump-true branch) '())
(equiv-lbl (ifjump-false branch) '())
(ifjump-poll? branch)
(gvm-instr-frame branch)
(gvm-instr-comment branch))))
((switch) ; branch is a 'switch'
(bb-put-branch! bb
(make-switch (switch-opnd branch)
(map (lambda (c)
(make-switch-case
(switch-case-obj c)
(equiv-lbl (switch-case-lbl c) '())))
(switch-cases branch))
(equiv-lbl (switch-default branch) '())
(switch-poll? branch)
(gvm-instr-frame branch)
(gvm-instr-comment branch))))
((jump) ; branch is a 'jump'
(if (not (first-class-jump? branch)) ; but not to an entry label
(let ((dest-lbl-num (jump-lbl? branch)))
(if dest-lbl-num
(jump-cascade-to
dest-lbl-num
(frame-size (gvm-instr-frame branch))
(jump-poll? branch)
'()
(lambda (lbl-num fs poll?)
(let* ((dest-bb (lbl-num->bb lbl-num bbs))
(last-branch (bb-branch-instr dest-bb)))
(if (and (empty-bb? dest-bb)
(or (not poll?)
(case (gvm-instr-type last-branch)
((ifjump)
(ifjump-poll? last-branch))
((switch)
(switch-poll? last-branch))
((jump)
(jump-poll? last-branch))
(else
#f))))
(let* ((new-fs (+ fs (bb-slots-gained dest-bb)))
(new-frame (frame-truncate
(gvm-instr-frame branch)
new-fs)))
(define (adjust-opnd opnd)
(cond ((stk? opnd)
(make-stk
(+ (- fs (bb-entry-frame-size dest-bb))
(stk-num opnd))))
((clo? opnd)
(make-clo (adjust-opnd (clo-base opnd))
(clo-index opnd)))
(else
opnd)))
(case (gvm-instr-type last-branch)
((ifjump)
(bb-put-branch! bb
(make-ifjump (ifjump-test last-branch)
(map adjust-opnd
(ifjump-opnds last-branch))
(equiv-lbl
(ifjump-true last-branch)
'())
(equiv-lbl
(ifjump-false last-branch)
'())
(or poll?
(ifjump-poll? last-branch))
new-frame
(gvm-instr-comment last-branch))))
((switch)
(bb-put-branch! bb
(make-switch (adjust-opnd (switch-opnd last-branch))
(map (lambda (c)
(make-switch-case
(switch-case-obj c)
(equiv-lbl (switch-case-lbl c) '())))
(switch-cases last-branch))
(equiv-lbl (switch-default last-branch) '())
(or poll?
(switch-poll? last-branch))
new-frame
(gvm-instr-comment last-branch))))
((jump)
(bb-put-branch! bb
(make-jump (adjust-opnd (jump-opnd last-branch))
(jump-nb-args last-branch)
(or poll?
(jump-poll? last-branch))
(jump-safe? last-branch)
new-frame
(gvm-instr-comment last-branch))))
(else
(compiler-internal-error
"bbs-remove-jump-cascades!, unknown branch type"))))
(bb-put-branch! bb
(make-jump (make-lbl lbl-num)
(jump-nb-args branch)
(or poll?
(jump-poll? branch))
(jump-safe? branch)
(frame-truncate
(gvm-instr-frame branch)
fs)
(gvm-instr-comment branch)))))))))))
(else
(compiler-internal-error
"bbs-remove-jump-cascades!, unknown branch type")))))
(bbs-for-each-bb remove-cascade! bbs))
(define (jump-lbl? branch)
(let ((opnd (jump-opnd branch)))
(if (lbl? opnd) (lbl-num opnd) #f)))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;; Step 2, Dead code removal:
(define (bbs-remove-dead-code! bbs)
(let ((new-basic-blocks (make-stretchable-vector #f))
(left-to-examine (queue-empty)))
(define (reachable ref bb)
(let ((ref-lbl-num (bb-lbl-num ref)))
(if bb (bb-add-reference! bb ref))
(if (not (stretchable-vector-ref new-basic-blocks ref-lbl-num))
(begin
(bb-references-set! ref '())
(bb-precedents-set! ref '())
(stretchable-vector-set! new-basic-blocks ref-lbl-num ref)
(queue-put! left-to-examine ref)))))
(define (direct-jump to-bb from-bb)
(reachable to-bb from-bb)
(bb-add-precedent! to-bb from-bb))
(define (scan-instr gvm-instr bb)
(define (scan-opnd gvm-opnd)
(cond ((not gvm-opnd))
((lbl? gvm-opnd)
(reachable (lbl-num->bb (lbl-num gvm-opnd) bbs) bb))
((clo? gvm-opnd)
(scan-opnd (clo-base gvm-opnd)))))
(case (gvm-instr-type gvm-instr)
((label)
'())
((apply)
(for-each scan-opnd (apply-opnds gvm-instr))
(if (apply-loc gvm-instr)
(scan-opnd (apply-loc gvm-instr))))
((copy)
(scan-opnd (copy-opnd gvm-instr))
(scan-opnd (copy-loc gvm-instr)))
((close)
(for-each (lambda (parm)
(reachable (lbl-num->bb (closure-parms-lbl parm) bbs) bb)
(scan-opnd (closure-parms-loc parm))
(for-each scan-opnd (closure-parms-opnds parm)))
(close-parms gvm-instr)))
((ifjump)
(for-each scan-opnd (ifjump-opnds gvm-instr))
(direct-jump (lbl-num->bb (ifjump-true gvm-instr) bbs) bb)
(direct-jump (lbl-num->bb (ifjump-false gvm-instr) bbs) bb))
((switch)
(scan-opnd (switch-opnd gvm-instr))
(for-each (lambda (c)
(direct-jump (lbl-num->bb (switch-case-lbl c) bbs) bb))
(switch-cases gvm-instr))
(direct-jump (lbl-num->bb (switch-default gvm-instr) bbs) bb))
((jump)
(let ((opnd (jump-opnd gvm-instr)))
(if (lbl? opnd)
(direct-jump (lbl-num->bb (lbl-num opnd) bbs) bb)
(scan-opnd (jump-opnd gvm-instr)))))
(else
(compiler-internal-error
"bbs-remove-dead-code!, unknown GVM instruction type"))))
(reachable (lbl-num->bb (bbs-entry-lbl-num bbs) bbs) #f)
(let loop ()
(if (not (queue-empty? left-to-examine))
(let ((bb (queue-get! left-to-examine)))
(begin
(scan-instr (bb-label-instr bb) bb)
(for-each (lambda (gvm-instr) (scan-instr gvm-instr bb))
(bb-non-branch-instrs bb))
(scan-instr (bb-branch-instr bb) bb)
(loop)))))
(bbs-basic-blocks-set! bbs new-basic-blocks)))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;; Step 3, Useless jump removal:
(define (bbs-remove-useless-jumps! bbs)
(let ((changed? #f))
(define (remove-useless-jump bb)
(let ((branch (bb-branch-instr bb)))
; is it a non-polling 'jump' to a label?
(if (and (eq? (gvm-instr-type branch) 'jump)
(not (first-class-jump? branch))
(not (jump-poll? branch))
(jump-lbl? branch))
(let* ((dest-bb (lbl-num->bb (jump-lbl? branch) bbs))
(frame1 (gvm-instr-frame (bb-last-non-branch-instr bb)))
(frame2 (gvm-instr-frame (bb-label-instr dest-bb))))
; is it a 'simple' label with the same frame as the last
; non-branch instruction?
(if (and (eq? (bb-label-type dest-bb) 'simple)
(frame-eq? frame1 frame2)
(= (length (bb-precedents dest-bb)) 1))
(begin
(set! changed? #t)
(bb-non-branch-instrs-set! bb
(append (bb-non-branch-instrs bb)
(bb-non-branch-instrs dest-bb)
'()))
(bb-branch-instr-set! bb
(bb-branch-instr dest-bb))
(remove-useless-jump bb)))))))
(bbs-for-each-bb remove-useless-jump bbs)
changed?))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;; Step 4, Common code removal:
(define (bbs-remove-common-code! bbs)
(let ((n (bbs-next-lbl-num bbs)))
(if (> n 300) ; if code is too large, don't optimize
#f
(let* ((hash-table-length (if (< n 50) 43 403))
(hash-table (make-vector hash-table-length '()))
(prim-table '())
(lbl-map (make-stretchable-vector #f))
(changed? #f))
(define (hash-prim prim)
(let ((n (length prim-table))
(i (pos-in-list prim prim-table)))
(if i
(- n i)
(begin
(set! prim-table (cons prim prim-table))
(+ n 1)))))
(define (hash-opnds l) ; this assumes that operands are encoded with nbs
(let loop ((l l) (n 0))
(if (pair? l)
(loop (cdr l)
(let ((x (car l)))
(if (lbl? x)
n
(modulo (+ (* n 10000) x) hash-table-length))))
n)))
(define (hash-bb bb) ; compute hash address for a basic block
(let ((branch (bb-branch-instr bb)))
(modulo
(case (gvm-instr-type branch)
((ifjump)
(+ (hash-opnds (ifjump-opnds branch))
(* 10 (hash-prim (ifjump-test branch)))
(* 100 (frame-size (gvm-instr-frame branch)))))
((switch)
(+ (hash-opnds (list (switch-opnd branch)))
(* 10 (length (switch-cases branch)))
(* 100 (frame-size (gvm-instr-frame branch)))))
((jump)
(+ (hash-opnds (list (jump-opnd branch)))
(* 10 (or (jump-nb-args branch) -1))
(* 100 (frame-size (gvm-instr-frame branch)))))
(else
0))
hash-table-length)))
(define (replacement-lbl-num lbl)
(or (stretchable-vector-ref lbl-map lbl) lbl))
(define (add-map! bb1 bb2) ; bb1 should be replaced by bb2
(stretchable-vector-set!
lbl-map
(bb-lbl-num bb1)
(bb-lbl-num bb2)))
(define (remove-map! bb)
(stretchable-vector-set!
lbl-map
(bb-lbl-num bb)
#f))
(define (enter-bb! bb) ; enter a basic block in the hash table
(let ((h (hash-bb bb)))
(vector-set! hash-table h
(add-bb bb (vector-ref hash-table h)))))
(define (add-bb bb l) ; add basic block 'bb' to list of basic blocks
(if (pair? l)
(let ((bb* (car l))) ; pick next basic block in list
(add-map! bb bb*) ; for now, assume that 'bb' = 'bb*'
(if (eqv-bb? bb bb*) ; are they the same?
(begin
(set! changed? #t)
l)
(begin
(remove-map! bb) ; they are not the same!
(if (eqv-gvm-instr? (bb-branch-instr bb) (bb-branch-instr bb*))
(extract-common-tail bb bb* ; check if tail is the same
(lambda (head head* tail)
(if (<= (length tail) 10) ; common tail long enough?
; no, so try rest of list
(cons bb* (add-bb bb (cdr l)))
; create bb for common tail
(let* ((lbl
(bbs-new-lbl! bbs))
(branch
(bb-branch-instr bb))
(fs**
(need-gvm-instrs tail branch))
(frame
(frame-truncate
(gvm-instr-frame
(if (null? head)
(bb-label-instr bb)
(car head)))
fs**))
(comment
(gvm-instr-comment (car tail)))
(bb**
(make-bb (make-label-simple lbl frame comment)
bbs)))
(bb-non-branch-instrs-set! bb** tail)
(bb-branch-instr-set! bb** branch)
(bb-non-branch-instrs-set! bb* (reverse head*))
(bb-branch-instr-set! bb*
(make-jump (make-lbl lbl) #f #f #f frame comment))
(bb-non-branch-instrs-set! bb (reverse head))
(bb-branch-instr-set! bb
(make-jump (make-lbl lbl) #f #f #f frame comment))
(set! changed? #t)
(cons bb (cons bb* (add-bb bb** (cdr l))))))))
;********** bb and bb* should not be put in this list!!!!
(cons bb* (add-bb bb (cdr l)))))))
(list bb)))
(define (extract-common-tail bb1 bb2 cont)
(let loop ((l1 (reverse (bb-non-branch-instrs bb1)))
(l2 (reverse (bb-non-branch-instrs bb2)))
(tail '()))
(if (and (pair? l1) (pair? l2))
(let ((i1 (car l1))
(i2 (car l2)))
(if (eqv-gvm-instr? i1 i2)
(loop (cdr l1) (cdr l2) (cons i1 tail))
(cont l1 l2 tail)))
(cont l1 l2 tail))))
(define (eqv-bb? bb1 bb2)
(let ((bb1-non-branch (bb-non-branch-instrs bb1))
(bb2-non-branch (bb-non-branch-instrs bb2)))
(and (= (length bb1-non-branch) (length bb2-non-branch))
(eqv-gvm-instr? (bb-label-instr bb1) (bb-label-instr bb2))
(eqv-gvm-instr? (bb-branch-instr bb1) (bb-branch-instr bb2))
(eqv-list? eqv-gvm-instr? bb1-non-branch bb2-non-branch))))
(define (eqv-list? pred? l1 l2)
(if (pair? l1)
(and (pair? l2)
(pred? (car l1) (car l2))
(eqv-list? pred? (cdr l1) (cdr l2)))
(not (pair? l2))))
(define (eqv-lbl-num? lbl1 lbl2)
(= (replacement-lbl-num lbl1)
(replacement-lbl-num lbl2)))
(define (eqv-gvm-opnd? opnd1 opnd2)
(if (not opnd1)
(not opnd2)
(and opnd2
(cond ((lbl? opnd1)
(and (lbl? opnd2)
(eqv-lbl-num? (lbl-num opnd1) (lbl-num opnd2))))
((clo? opnd1)
(and (clo? opnd2)
(= (clo-index opnd1) (clo-index opnd2))
(eqv-gvm-opnd? (clo-base opnd1)
(clo-base opnd2))))
(else
(eqv? opnd1 opnd2))))))
(define (eqv-key-pair? key-pair1 key-pair2)
(and (eq? (car key-pair1) (car key-pair2))
(eqv-gvm-opnd? (cdr key-pair1) (cdr key-pair2))))
(define (eqv-gvm-instr? instr1 instr2)
(define (eqv-closure-parms? p1 p2)
(and (eqv-gvm-opnd? (closure-parms-loc p1)
(closure-parms-loc p2))
(eqv-lbl-num? (closure-parms-lbl p1)
(closure-parms-lbl p2))
(eqv-list? eqv-gvm-opnd?
(closure-parms-opnds p1)
(closure-parms-opnds p2))))
(define (has-debug-info? instr)
(let ((node (comment-get (gvm-instr-comment instr) 'node)))
(and node
(let ((env (node-env node)))
(and (debug? env)
(or (debug-location? env)
(debug-source? env)
(debug-environments? env)))))))
(let ((type1 (gvm-instr-type instr1))
(type2 (gvm-instr-type instr2)))
(and (eq? type1 type2)
(frame-eq? (gvm-instr-frame instr1) (gvm-instr-frame instr2))
(not (has-debug-info? instr1))
(not (has-debug-info? instr2))
(case type1
((label)
(let ((ltype1 (label-type instr1))
(ltype2 (label-type instr2)))
(and (eq? ltype1 ltype2)
(case ltype1
((simple return task-entry task-return)
#t)
((entry)
(and (= (label-entry-nb-parms instr1)
(label-entry-nb-parms instr2))
(eqv-list? eqv-gvm-opnd?
(label-entry-opts instr1)
(label-entry-opts instr2))
(if (label-entry-keys instr1)
(and (label-entry-keys instr2)
(eqv-list? eqv-key-pair?
(label-entry-keys instr1)
(label-entry-keys instr2)))
(not (label-entry-keys instr2)))
(eq? (label-entry-rest? instr1)
(label-entry-rest? instr2))
(eq? (label-entry-closed? instr1)
(label-entry-closed? instr2))))
(else
(compiler-internal-error
"eqv-gvm-instr?, unknown label type"))))))
((apply)
(and (eq? (apply-prim instr1) (apply-prim instr2))
(eqv-list? eqv-gvm-opnd?
(apply-opnds instr1)
(apply-opnds instr2))
(eqv-gvm-opnd? (apply-loc instr1)
(apply-loc instr2))))
((copy)
(and (eqv-gvm-opnd? (copy-opnd instr1)
(copy-opnd instr2))
(eqv-gvm-opnd? (copy-loc instr1)
(copy-loc instr2))))
((close)
(eqv-list? eqv-closure-parms?
(close-parms instr1)
(close-parms instr2)))
((ifjump)
(and (eq? (ifjump-test instr1)
(ifjump-test instr2))
(eqv-list? eqv-gvm-opnd?
(ifjump-opnds instr1)
(ifjump-opnds instr2))
(eqv-lbl-num? (ifjump-true instr1)
(ifjump-true instr2))
(eqv-lbl-num? (ifjump-false instr1)
(ifjump-false instr2))
(eq? (ifjump-poll? instr1)
(ifjump-poll? instr2))))
((switch)
(and (eqv-gvm-opnd? (switch-opnd instr1)
(switch-opnd instr2))
(every? (lambda (x)
(and (eqv? (switch-case-obj (car x))
(switch-case-obj (cdr x)))
(eqv-lbl-num? (switch-case-lbl (car x))
(switch-case-lbl (cdr x)))))
(map cons
(switch-cases instr1)
(switch-cases instr2)))
(eqv-lbl-num? (switch-default instr1)
(switch-default instr2))
(eq? (switch-poll? instr1)
(switch-poll? instr2))))
((jump)
(and (eqv-gvm-opnd? (jump-opnd instr1)
(jump-opnd instr2))
(eqv? (jump-nb-args instr1)
(jump-nb-args instr2))
(eq? (jump-poll? instr1)
(jump-poll? instr2))
(eq? (jump-safe? instr1)
(jump-safe? instr2))))
(else
(compiler-internal-error
"eqv-gvm-instr?, unknown 'gvm-instr':" instr1))))))
; Fill hash table, remove equivalent basic blocks and common tails
(bbs-for-each-bb enter-bb! bbs)
; Reconstruct bbs
(bbs-entry-lbl-num-set! bbs
(replacement-lbl-num (bbs-entry-lbl-num bbs)))
(bbs-for-each-bb
(lambda (bb)
(if bb
(replace-label-references! bb replacement-lbl-num)))
bbs)
changed?))))
(define (replace-label-references! bb replacement-lbl-num)
(define (update-gvm-opnd opnd)
(if opnd
(cond ((lbl? opnd)
(make-lbl (replacement-lbl-num (lbl-num opnd))))
((clo? opnd)
(make-clo (update-gvm-opnd (clo-base opnd)) (clo-index opnd)))
(else
opnd))
opnd))
(define (update-gvm-instr instr)
(define (update-closure-parms p)
(make-closure-parms
(update-gvm-opnd (closure-parms-loc p))
(replacement-lbl-num (closure-parms-lbl p))
(map update-gvm-opnd (closure-parms-opnds p))))
(case (gvm-instr-type instr)
((apply)
(make-apply (apply-prim instr)
(map update-gvm-opnd (apply-opnds instr))
(update-gvm-opnd (apply-loc instr))
(gvm-instr-frame instr)
(gvm-instr-comment instr)))
((copy)
(make-copy (update-gvm-opnd (copy-opnd instr))
(update-gvm-opnd (copy-loc instr))
(gvm-instr-frame instr)
(gvm-instr-comment instr)))
((close)
(make-close
(map update-closure-parms (close-parms instr))
(gvm-instr-frame instr)
(gvm-instr-comment instr)))
((ifjump)
(make-ifjump (ifjump-test instr)
(map update-gvm-opnd (ifjump-opnds instr))
(replacement-lbl-num (ifjump-true instr))
(replacement-lbl-num (ifjump-false instr))
(ifjump-poll? instr)
(gvm-instr-frame instr)
(gvm-instr-comment instr)))
((switch)
(make-switch (update-gvm-opnd (switch-opnd instr))
(map (lambda (c)
(make-switch-case (switch-case-obj c)
(replacement-lbl-num
(switch-case-lbl c))))
(switch-cases instr))
(replacement-lbl-num (switch-default instr))
(switch-poll? instr)
(gvm-instr-frame instr)
(gvm-instr-comment instr)))
((jump)
(make-jump (update-gvm-opnd (jump-opnd instr))
(jump-nb-args instr)
(jump-poll? instr)
(jump-safe? instr)
(gvm-instr-frame instr)
(gvm-instr-comment instr)))
(else
(compiler-internal-error
"update-gvm-instr, unknown 'instr':" instr))))
(bb-non-branch-instrs-set! bb
(map update-gvm-instr (bb-non-branch-instrs bb)))
(bb-branch-instr-set! bb
(update-gvm-instr (bb-branch-instr bb))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;; Step 5, Basic block set ordering:
(define (bbs-order! bbs)
(let ((ordered-blocks (queue-empty))
(left-to-schedule (stretchable-vector-copy (bbs-basic-blocks bbs))))
; test if a basic block is in 'left-to-schedule' and return the
; basic block if it is
(define (left-to-schedule? bb)
(stretchable-vector-ref left-to-schedule (bb-lbl-num bb)))
; remove basic block from 'left-to-schedule'
(define (remove-bb! bb)
(stretchable-vector-set! left-to-schedule (bb-lbl-num bb) #f)
bb)
; return a basic block which ends with a branch to 'bb' (and that is
; still in 'left-to-schedule') or #f if there aren't any
(define (prec-bb bb)
(let loop ((lst (bb-precedents bb)) (best #f) (best-fs #f))
(if (null? lst)
best
(let* ((x (car lst))
(x-fs (bb-exit-frame-size x)))
(if (and (left-to-schedule? x)
(or (not best) (< x-fs best-fs)))
(loop (cdr lst) x x-fs)
(loop (cdr lst) best best-fs))))))
; return the basic block which 'bb' jumps to (and that is still in
; bbs) or #f if there aren't any
(define (succ-bb bb)
(define (branches-to-lbl? bb)
(let ((branch (bb-branch-instr bb)))
(case (gvm-instr-type branch)
((ifjump) #t)
((switch) #t)
((jump) (lbl? (jump-opnd branch)))
(else
(compiler-internal-error
"bbs-order!, unknown branch type")))))
(define (best-succ bb1 bb2) ; heuristic that determines which
(if (branches-to-lbl? bb1) ; bb is most frequently executed
bb1
(if (branches-to-lbl? bb2)
bb2
(if (< (bb-exit-frame-size bb1)
(bb-exit-frame-size bb2))
bb2
bb1))))
(let ((branch (bb-branch-instr bb)))
(case (gvm-instr-type branch)
((ifjump)
(let* ((true-bb
(left-to-schedule?
(lbl-num->bb (ifjump-true branch) bbs)))
(false-bb
(left-to-schedule?
(lbl-num->bb (ifjump-false branch) bbs))))
(if (and true-bb false-bb)
(best-succ true-bb false-bb)
(or true-bb false-bb))))
((switch)
(left-to-schedule?
(lbl-num->bb (switch-default branch) bbs)))
((jump)
(let ((opnd (jump-opnd branch)))
(and (lbl? opnd)
(left-to-schedule?
(lbl-num->bb (lbl-num opnd) bbs)))))
(else
(compiler-internal-error
"bbs-order!, unknown branch type")))))
; schedule a given basic block 'bb' with it's predecessors and
; successors.
(define (schedule-from bb)
(queue-put! ordered-blocks bb)
(let ((x (succ-bb bb)))
(if x
(begin
(schedule-around (remove-bb! x))
(let ((y (succ-bb bb)))
(if y
(schedule-around (remove-bb! y)))))))
(schedule-refs bb))
(define (schedule-around bb)
(let ((x (prec-bb bb)))
(if x
(let ((bb-list (schedule-back (remove-bb! x) '())))
(queue-put! ordered-blocks x)
(schedule-forw bb)
(for-each schedule-refs bb-list))
(schedule-from bb))))
(define (schedule-back bb bb-list)
(let ((bb-list* (cons bb bb-list))
(x (prec-bb bb)))
(if x
(let ((bb-list (schedule-back (remove-bb! x) bb-list*)))
(queue-put! ordered-blocks x)
bb-list)
bb-list*)))
(define (schedule-forw bb)
(queue-put! ordered-blocks bb)
(let ((x (succ-bb bb)))
(if x
(begin
(schedule-forw (remove-bb! x))
(let ((y (succ-bb bb)))
(if y
(schedule-around (remove-bb! y)))))))
(schedule-refs bb))
(define (schedule-refs bb)
(for-each
(lambda (x)
(if (left-to-schedule? x)
(schedule-around (remove-bb! x))))
(bb-references bb)))
(schedule-from (remove-bb! (lbl-num->bb (bbs-entry-lbl-num bbs) bbs)))
(let ((basic-blocks (make-stretchable-vector #f))
(lbl-map (make-stretchable-vector #f)))
(define (replacement-lbl-num lbl)
(or (stretchable-vector-ref lbl-map lbl) lbl))
(let loop ((lst (queue->list ordered-blocks)) (i 1))
(if (pair? lst)
(let* ((bb (car lst))
(label-instr (bb-label-instr bb)))
(stretchable-vector-set! basic-blocks i bb)
(stretchable-vector-set! lbl-map (label-lbl-num label-instr) i)
(label-lbl-num-set! label-instr i)
(loop (cdr lst) (+ i 1)))
(begin
; Reconstruct bbs
(bbs-next-lbl-num-set! bbs i)
(bbs-basic-blocks-set! bbs basic-blocks)
(bbs-entry-lbl-num-set! bbs
(replacement-lbl-num (bbs-entry-lbl-num bbs)))
(bbs-for-each-bb
(lambda (bb)
(replace-label-references!
bb
replacement-lbl-num))
bbs)))))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;
;; Sequentialization of a basic block set:
;; --------------------------------------
;; The procedure 'bbs->code-list' transforms a 'purified' basic block set
;; into a sequence of virtual machine instructions. Each element of the
;; resulting list is a 'code' object that contains a GVM instruction,
;; a pointer to the basic block it came from and a `slots needed' index
;; that specifies the minimum number of slots that have to be kept (relative
;; to the start of the frame) after the instruction is executed.
;; The first element of the code list is the entry label for the piece of code.
(define (make-code bb gvm-instr sn) (vector bb gvm-instr sn))
(define (code-bb code) (vector-ref code 0))
(define (code-gvm-instr code) (vector-ref code 1))
(define (code-slots-needed code) (vector-ref code 2))
(define (code-slots-needed-set! code n) (vector-set! code 2 n))
(define (bbs->code-list bbs)
(let ((code-list (linearize bbs)))
(setup-slots-needed! code-list)
code-list))
(define (linearize bbs) ; convert bbs into list of GVM instructions
(let ((code-queue (queue-empty)))
(define (put-bb bb)
(define (put-instr gvm-instr)
(queue-put! code-queue (make-code bb gvm-instr #f)))
(put-instr (bb-label-instr bb))
(for-each put-instr (bb-non-branch-instrs bb))
(put-instr (bb-branch-instr bb)))
(bbs-for-each-bb put-bb bbs)
(queue->list code-queue)))
(define (setup-slots-needed! code-list) ; setup slots-needed field
; Backward pass to set slots-needed field
(let loop1 ((lst (reverse code-list)) (sn-rest #f))
(if (pair? lst)
(let* ((code (car lst))
(gvm-instr (code-gvm-instr code)))
(loop1
(cdr lst)
(case (gvm-instr-type gvm-instr)
((label)
(if (> sn-rest (frame-size (gvm-instr-frame gvm-instr)))
(compiler-internal-error
"setup-slots-needed!, incoherent slots needed for label"))
(code-slots-needed-set! code sn-rest)
#f)
((ifjump switch jump)
(let ((sn (frame-size (gvm-instr-frame gvm-instr))))
(code-slots-needed-set! code sn)
(need-gvm-instr gvm-instr sn)))
(else
(code-slots-needed-set! code sn-rest)
(need-gvm-instr gvm-instr sn-rest))))))))
(define (need-gvm-instrs non-branch branch)
(if (pair? non-branch)
(need-gvm-instr (car non-branch)
(need-gvm-instrs (cdr non-branch) branch))
(need-gvm-instr branch
(frame-size (gvm-instr-frame branch)))))
(define (need-gvm-instr gvm-instr sn-rest)
(case (gvm-instr-type gvm-instr)
((label)
sn-rest)
((apply)
(let ((loc (apply-loc gvm-instr)))
(need-gvm-opnds (apply-opnds gvm-instr)
(need-gvm-loc-opnd loc
(need-gvm-loc loc sn-rest)))))
((copy)
(let ((loc (copy-loc gvm-instr)))
(need-gvm-opnd (copy-opnd gvm-instr)
(need-gvm-loc-opnd loc
(need-gvm-loc loc sn-rest)))))
((close)
(let ((parms (close-parms gvm-instr)))
(define (need-parms-opnds p)
(if (null? p)
sn-rest
(need-gvm-opnds (closure-parms-opnds (car p))
(need-parms-opnds (cdr p)))))
(define (need-parms-loc p)
(if (null? p)
(need-parms-opnds parms)
(let ((loc (closure-parms-loc (car p))))
(need-gvm-loc-opnd loc
(need-gvm-loc loc (need-parms-loc (cdr p)))))))
(need-parms-loc parms)))
((ifjump)
(need-gvm-opnds (ifjump-opnds gvm-instr) sn-rest))
((switch)
(need-gvm-opnd (switch-opnd gvm-instr) sn-rest))
((jump)
(need-gvm-opnd (jump-opnd gvm-instr) sn-rest))
(else
(compiler-internal-error
"need-gvm-instr, unknown 'gvm-instr':" gvm-instr))))
(define (need-gvm-loc loc sn-rest)
(if (and loc (stk? loc) (>= (stk-num loc) sn-rest))
(- (stk-num loc) 1)
sn-rest))
(define (need-gvm-loc-opnd gvm-loc slots-needed)
(if (and gvm-loc (clo? gvm-loc))
(need-gvm-opnd (clo-base gvm-loc) slots-needed)
slots-needed))
(define (need-gvm-opnd gvm-opnd slots-needed)
(if gvm-opnd
(cond ((stk? gvm-opnd)
(max (stk-num gvm-opnd) slots-needed))
((clo? gvm-opnd)
(need-gvm-opnd (clo-base gvm-opnd) slots-needed))
(else
slots-needed))
slots-needed))
(define (need-gvm-opnds gvm-opnds slots-needed)
(if (null? gvm-opnds)
slots-needed
(need-gvm-opnd (car gvm-opnds)
(need-gvm-opnds (cdr gvm-opnds) slots-needed))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;
;; Basic block writing:
;; -------------------
(define (write-bb bb port)
(write-gvm-instr (bb-label-instr bb) port)
(display " [precedents=" port)
(write (map bb-lbl-num (bb-precedents bb)) port)
(display "]" port)
(newline port)
(for-each (lambda (x) (write-gvm-instr x port) (newline port))
(bb-non-branch-instrs bb))
(write-gvm-instr (bb-branch-instr bb) port))
(define (write-bbs bbs port)
(bbs-for-each-bb
(lambda (bb)
(if (= (bb-lbl-num bb) (bbs-entry-lbl-num bbs))
(begin (display "**** Entry block:" port) (newline port)))
(write-bb bb port)
(newline port))
bbs))
(define show-slots-needed? #f)
(set! show-slots-needed? #f)
(define (virtual.dump procs port)
(let ((proc-seen (queue-empty))
(proc-left (queue-empty)))
(define (scan-obj obj)
(if (and (proc-obj? obj)
(proc-obj-code obj)
(not (memq obj (queue->list proc-seen))))
(begin
(queue-put! proc-seen obj)
(queue-put! proc-left obj))))
(define (scan-opnd gvm-opnd)
(cond ((not gvm-opnd))
((obj? gvm-opnd)
(scan-obj (obj-val gvm-opnd)))
((clo? gvm-opnd)
(scan-opnd (clo-base gvm-opnd)))))
(define (dump-proc p)
(define (scan-code code)
(let ((gvm-instr (code-gvm-instr code)))
(if show-slots-needed?
(begin
(display "sn=" port)
(display (code-slots-needed code) port)
(display " | " port)))
(write-gvm-instr gvm-instr port)
(newline port)
(case (gvm-instr-type gvm-instr)
((apply)
(for-each scan-opnd (apply-opnds gvm-instr))
(if (apply-loc gvm-instr)
(scan-opnd (apply-loc gvm-instr))))
((copy)
(scan-opnd (copy-opnd gvm-instr))
(scan-opnd (copy-loc gvm-instr)))
((close)
(for-each (lambda (parms)
(scan-opnd (closure-parms-loc parms))
(for-each scan-opnd (closure-parms-opnds parms)))
(close-parms gvm-instr)))
((ifjump)
(for-each scan-opnd (ifjump-opnds gvm-instr)))
((switch)
(scan-opnd (switch-opnd gvm-instr))
(for-each (lambda (c) (scan-obj (switch-case-obj c)))
(switch-cases gvm-instr)))
((jump)
(scan-opnd (jump-opnd gvm-instr)))
(else
'()))))
(if (proc-obj-primitive? p)
(display "**** #<primitive " port)
(display "**** #<procedure " port))
(write (string->canonical-symbol (proc-obj-name p)) port)
(display "> =" port)
(newline port)
(let ((x (proc-obj-code p)))
(if (bbs? x)
(let loop ((l (bbs->code-list x))
(prev-filename "")
(prev-line 0))
(if (pair? l)
(let* ((code (car l))
(instr (code-gvm-instr code))
(node (comment-get (gvm-instr-comment instr) 'node))
(src (node-source node))
(loc (and src (source-locat src)))
(filename
(if (and loc (string? (vector-ref loc 0)));;;;;;;;;;;;;
(vector-ref loc 0)
prev-filename))
(line
(if (and loc (string? (vector-ref loc 0)))
(+ (**filepos-line (vector-ref loc 1)) 1)
prev-line)))
(if (or (not (string=? filename prev-filename))
(not (= line prev-line)))
(begin
(display "#line " port)
(display line port)
(if (not (string=? filename prev-filename))
(begin
(display " " port)
(write filename port)))
(newline port)))
(scan-code code)
(loop (cdr l) filename line))
(newline port)))
(begin
(display "C procedure of arity " port)
(display (c-proc-arity x) port)
(display " and body:" port)
(newline port)
(display (c-proc-body x) port)
(newline port)))))
(for-each (lambda (proc) (scan-opnd (make-obj proc))) procs)
(let loop ()
(if (not (queue-empty? proc-left))
(begin
(dump-proc (queue-get! proc-left))
(loop))))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;
;; Virtual instruction writing:
;; ---------------------------
(define (write-gvm-instr gvm-instr port)
(define (write-closure-parms parms)
(display " " port)
(let ((len (+ 1 (write-gvm-opnd (closure-parms-loc parms) port))))
(display " = (" port)
(let ((len (+ len (+ 4 (write-gvm-lbl (closure-parms-lbl parms) port)))))
(+ len (write-spaced-opnd-list (closure-parms-opnds parms) port)))))
(define (write-spaced-opnd-list l port)
(let loop ((l l) (len 0))
(if (pair? l)
(let ((opnd (car l)))
(display " " port)
(loop (cdr l) (+ len (+ 1 (write-gvm-opnd opnd port)))))
(begin
(display ")" port)
(+ len 1)))))
(define (write-opnd-list l port)
(if (pair? l)
(let ((len (write-gvm-opnd (car l) port)))
(+ len (write-spaced-opnd-list (cdr l) port)))
(begin
(display ")" port)
1)))
(define (write-key-pair-list keys port)
(if keys
(begin
(display " (" port)
(if (pair? keys)
(let loop ((l keys))
(let* ((key-pair (car l))
(key (car key-pair))
(opnd (cdr key-pair))
(rest (cdr l)))
(display "(" port)
(let ((len (+ 1 (write-returning-len key port))))
(display " " port)
(let ((len (+ len (+ 1 (write-gvm-opnd opnd port)))))
(display ")" port)
(if (pair? rest)
(begin
(display " " port)
(+ len (+ 2 (loop rest))))
(begin
(display ")" port)
(+ len 4)))))))
(begin
(display ")" port)
3)))
0))
(define (write-param-pattern gvm-instr port)
(display "nparams=" port)
(let ((len (+ 8 (write-returning-len
(label-entry-nb-parms gvm-instr)
port))))
(display " (" port)
(let ((len (+ len
(+ 2
(write-opnd-list
(label-entry-opts gvm-instr)
port)))))
(let ((len (+ len
(write-key-pair-list
(label-entry-keys gvm-instr)
port))))
(if (label-entry-rest? gvm-instr)
(begin (display " +" port) (+ len 2))
len)))))
(define (write-prim-applic prim opnds port)
(display "(" port)
(let ((len (+ 1 (display-returning-len (proc-obj-name prim) port))))
(+ len (write-spaced-opnd-list opnds port))))
(define (write-instr gvm-instr)
(case (gvm-instr-type gvm-instr)
((label)
(let ((len (write-gvm-lbl (label-lbl-num gvm-instr) port)))
(display " fs=" port)
(let ((len (+ len
(+ 4 (write-returning-len
(frame-size (gvm-instr-frame gvm-instr))
port)))))
(case (label-type gvm-instr)
((simple)
len)
((entry)
(if (label-entry-closed? gvm-instr)
(begin
(display " closure-entry-point " port)
(+ len (+ 21 (write-param-pattern gvm-instr port))))
(begin
(display " entry-point " port)
(+ len (+ 13 (write-param-pattern gvm-instr port))))))
((return)
(display " return-point" port)
(+ len 13))
((task-entry)
(display " task-entry-point" port)
(+ len 17))
((task-return)
(display " task-return-point" port)
(+ len 18))
(else
(compiler-internal-error
"write-gvm-instr, unknown label type"))))))
((apply)
(display " " port)
(let ((len (+ 2 (write-gvm-opnd (apply-loc gvm-instr) port))))
(display " = " port)
(+ len
(+ 3
(write-prim-applic (apply-prim gvm-instr)
(apply-opnds gvm-instr)
port)))))
((copy)
(display " " port)
(let ((len (+ 2 (write-gvm-opnd (copy-loc gvm-instr) port))))
(display " = " port)
(+ len (+ 3 (write-gvm-opnd (copy-opnd gvm-instr) port)))))
((close)
(display " close" port)
(let ((len (+ 7 (write-closure-parms (car (close-parms gvm-instr))))))
(let loop ((l (cdr (close-parms gvm-instr))) (len len))
(if (pair? l)
(let ((x (car l)))
(display "," port)
(loop (cdr l) (+ len (+ 1 (write-closure-parms x)))))
len))))
((ifjump)
(display " if " port)
(let ((len (+ 5
(write-prim-applic (ifjump-test gvm-instr)
(ifjump-opnds gvm-instr)
port))))
(let ((len (+ len
(if (ifjump-poll? gvm-instr)
(begin (display " jump/poll " port) 11)
(begin (display " jump " port) 6)))))
(display "fs=" port)
(let ((len (+ len
(+ 3 (write-returning-len
(frame-size (gvm-instr-frame gvm-instr))
port)))))
(display " " port)
(let ((len (+ len
(+ 1 (write-gvm-lbl
(ifjump-true gvm-instr)
port)))))
(display " else " port)
(+ len (+ 6 (write-gvm-lbl
(ifjump-false gvm-instr)
port))))))))
((switch)
(display " " port)
(let ((len (+ 2
(if (switch-poll? gvm-instr)
(begin (display "switch/poll " port) 12)
(begin (display "switch " port) 7)))))
(display "fs=" port)
(let ((len (+ len
(+ 3 (write-returning-len
(frame-size (gvm-instr-frame gvm-instr))
port)))))
(display " " port)
(let ((len (+ len
(+ 1 (write-gvm-opnd (switch-opnd gvm-instr) port)))))
(display " (" port)
(let ((len
(let loop ((cases (switch-cases gvm-instr))
(len (+ len 2)))
(if (pair? cases)
(let ((c (car cases)))
(let ((len (+ len
(write-gvm-obj (switch-case-obj c)
port))))
(display " => " port)
(let ((len (+ len
(+ 4 (write-gvm-lbl (switch-case-lbl c)
port)))))
(let ((next (cdr cases)))
(if (null? next)
len
(begin
(display ", " port)
(loop next (+ len 2))))))))
len))))
(display ") " port)
(+ len
(+ 2 (write-gvm-lbl
(switch-default gvm-instr)
port))))))))
((jump)
(display " " port)
(let ((len (+ 2
(if (jump-poll? gvm-instr)
(begin (display "jump/poll" port) 9)
(begin (display "jump" port) 4)))))
(let ((len (+ len
(if (jump-safe? gvm-instr)
(begin (display "/safe " port) 6)
(begin (display " " port) 1)))))
(display "fs=" port)
(let ((len (+ len
(+ 3 (write-returning-len
(frame-size (gvm-instr-frame gvm-instr))
port)))))
(display " " port)
(let ((len (+ len
(+ 1 (write-gvm-opnd (jump-opnd gvm-instr) port)))))
(+ len
(if (jump-nb-args gvm-instr)
(begin
(display " nargs=" port)
(+ 7 (write-returning-len
(jump-nb-args gvm-instr)
port)))
0)))))))
(else
(compiler-internal-error
"write-gvm-instr, unknown 'gvm-instr':"
gvm-instr))))
(define (spaces n)
(if (> n 0)
(if (> n 7)
(begin (display " " port) (spaces (- n 8)))
(begin (display " " port) (spaces (- n 1))))))
(let ((len (write-instr gvm-instr)))
(spaces (- 43 len))
(display " " port)
(write-frame (gvm-instr-frame gvm-instr) port))
(let ((x (gvm-instr-comment gvm-instr)))
(if x
(let ((y (comment-get x 'text)))
(if y
(begin
(display " ; " port)
(display y port)))))))
(define (write-frame frame port)
(define (write-var var opnd sep)
(display sep port)
(write-gvm-opnd opnd port)
(if var
(begin
(display "=" port)
(cond ((eq? var closure-env-var)
(write (map var-name (frame-closed frame))
port))
((eq? var ret-var)
(display "#" port))
((temp-var? var)
(display "." port))
(else
(write (var-name var) port))))))
(define (live? var)
(let ((live (frame-live frame)))
(or (varset-member? var live)
(and (eq? var closure-env-var)
(varset-intersects?
live
(list->varset (frame-closed frame)))))))
(let loop1 ((i 1) (l (reverse (frame-slots frame))) (sep "; "))
(if (pair? l)
(let ((var (car l)))
(write-var (if (live? var) var #f) (make-stk i) sep)
(loop1 (+ i 1) (cdr l) " "))
(let loop2 ((i 0) (l (frame-regs frame)) (sep sep))
(if (pair? l)
(let ((var (car l)))
(if (live? var)
(begin
(write-var var (make-reg i) sep)
(loop2 (+ i 1) (cdr l) " "))
(loop2 (+ i 1) (cdr l) sep))))))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;
;; Operand writing:
;; ---------------
(define (write-gvm-opnd gvm-opnd port)
(cond ((not gvm-opnd)
(display "." port)
1)
((reg? gvm-opnd)
(display "r" port)
(+ 1 (write-returning-len (reg-num gvm-opnd) port)))
((stk? gvm-opnd)
(display "frame[" port)
(let ((len (write-returning-len (stk-num gvm-opnd) port)))
(display "]" port)
(+ 7 len)))
((glo? gvm-opnd)
(display "global[" port)
(let ((len (write-returning-len (glo-name gvm-opnd) port)))
(display "]" port)
(+ 8 len)))
((clo? gvm-opnd)
(let ((len (write-gvm-opnd (clo-base gvm-opnd) port)))
(display "[" port)
(let ((len (+ len
(+ 1 (write-returning-len
(clo-index gvm-opnd)
port)))))
(display "]" port)
(+ len 1))))
((lbl? gvm-opnd)
(write-gvm-lbl (lbl-num gvm-opnd) port))
((obj? gvm-opnd)
(display "'" port)
(+ (write-gvm-obj (obj-val gvm-opnd) port) 1))
(else
(compiler-internal-error
"write-gvm-opnd, unknown 'gvm-opnd':"
gvm-opnd))))
(define (write-gvm-lbl lbl port)
(display "#" port)
(+ (write-returning-len lbl port) 1))
(define (write-gvm-obj val port)
(cond ((proc-obj? val)
(if (proc-obj-primitive? val)
(display "#<primitive " port)
(display "#<procedure " port))
(let ((len
(write-returning-len
(string->canonical-symbol (proc-obj-name val))
port)))
(display ">" port)
(+ len 13)))
(else
(write-returning-len val port))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (virtual.begin!) ; initialize module
(set! *opnd-table* '#())
(set! *opnd-table-alloc* 0)
'())
(define (virtual.end!) ; finalize module
(set! *opnd-table* '())
'())
;;;============================================================================
Jump to Line
Something went wrong with that request. Please try again.