Skip to content
Browse files

More work on register spilling

  • Loading branch information...
1 parent cddab4b commit a2ac2d15e96a06d6d50133f516f424856e055cab @vgeddes committed
Showing with 160 additions and 39 deletions.
  1. +8 −3 Makefile
  2. +0 −1 arch/x86-64/arch-x86-64.scm
  3. +97 −26 liveness.scm
  4. +7 −8 machine.scm
  5. +1 −1 pass.scm
  6. +47 −0 tests/test-spill.scm
View
11 Makefile
@@ -2,7 +2,7 @@
PACKAGE := scc
VERSION := 0.1
-objects := nodes.o pass.o main.o machine.o liveness.o utils.o tree.o arch.o
+objects := nodes.o pass.o machine.o liveness.o utils.o tree.o arch.o
objects_x86_64 = arch/x86-64/arch-x86-64.o arch/x86-64/spec-x86-64.o arch/x86-64/rules-x86-64.o
@@ -10,7 +10,7 @@ tests_bin = tests/test-fast-match
all: scc tests
-scc: $(objects) $(objects_x86_64)
+scc: main.o $(objects) $(objects_x86_64)
csc -o $@ $^
# extra dependencies
@@ -23,17 +23,22 @@ arch/x86-64/arch-x86-64.o: arch-syntax.scm
arch/x86-64/spec-x86-64.o: arch-syntax.scm
arch/x86-64/rules-x86-64.o: arch-syntax.scm munch-syntax.scm
arch.o: nodes.scm
+tests/test-spill.o: arch-syntax.scm
+
# default rule
%.o: %.scm
csc -c $<
-tests:
+tests: tests/test-spill
tests/test-fast-match: tests/test-fast-match.scm fast-match-syntax.scm
csc -o $@ $<
+tests/test-spill: tests/test-spill.o $(objects) $(objects_x86_64)
+ csc -o $@ $^
+
asm-test: asm-test.o asm-test.c
gcc -o asm-test -o $@ $^
View
1 arch/x86-64/arch-x86-64.scm
@@ -179,7 +179,6 @@
cxt))
-
;; Selects x86-64 instructions for a tree node
;;
(define (emit-statement-x86-64 block tree)
View
123 liveness.scm
@@ -14,7 +14,7 @@
(define-struct scan-context (mcxt ranges hreg-pool))
(define-struct node (index value pred succ in out def use live))
(define-struct range (vreg hreg pref start end))
-(define-struct pool (hregs ranges))
+(define-struct pool (hregs reg-names ranges))
(define assert-not-reached
(lambda ()
@@ -50,7 +50,7 @@
((null? instr) (reverse nodes))
(else
(let ((number (counter)))
- (mc-instr-number-set! instr number)
+ (mc-instr-index-set! instr number)
(f (mc-instr-next instr)
(cons (make-node number instr '() '() '() '() '() '() '()) nodes)))))))
(head (car nodes))
@@ -246,13 +246,13 @@
(loop-fx fx* (cons fx acc))
(loop-fx fx* acc)))))
(loop hreg*))))
- (make-pool hregs table)))
+ (make-pool hregs hregs table)))
(define (pool-empty? pool)
(null? (pool-hregs pool)))
(define (pool-reset pool)
- (pool-hregs-set! pool *regs*))
+ (pool-hregs-set! pool (pool-reg-names pool)))
(define (pool-push pool hreg)
(pool-hregs-set! pool (cons hreg (pool-hregs pool))))
@@ -260,6 +260,9 @@
(define (pool-member? pool hreg)
(and (memq hreg (pool-hregs pool)) #t))
+(define (pool-count pool)
+ (length (pool-hregs pool)))
+
(define (pool-remove pool hreg)
(pool-hregs-set! pool (lset-difference eq? (pool-hregs pool) (list hreg)))
hreg)
@@ -331,6 +334,51 @@
(define (update-active active range)
(sort (cons range active) range-ends-before?))
+;; remove range
+(define (remove-range vreg ranges)
+ (let f ((range* ranges) (x '()))
+ (match range*
+ (() (sort x range-starts-before?))
+ ((range . range*)
+ (cond
+ ((mc-vreg-equal? (range-vreg range) vreg)
+ (f range* x))
+ (else
+ (range-hreg-set! range #f)
+ (f range* (cons range x))))))))
+
+;; For our spilling heuristic, we select the longest range in active
+(define (select-range-to-spill active)
+ (car (sort active
+ (lambda (r1 r2)
+ (>= (- (range-end r1) (range-start r1)) (- (range-end r2) (range-start r2)))))))
+
+(define (add-spill spills index cxt instr vreg)
+ (let ((tmp (mc-context-allocate-vreg cxt (gensym 'g))))
+ ;; replace vreg use with another tmp, which will represent a scratch register. The vreg contents are now
+ ;; passed between/from the stack and the scratch register
+ ;; add spill info for the user
+ (cond
+ ((and (mc-instr-is-read? instr vreg) (mc-instr-is-written? instr vreg))
+ (hash-table-set! spills (mc-instr-index instr) (list 'read-write instr index tmp)))
+ ((mc-instr-is-read? instr vreg)
+ (hash-table-set! spills (mc-instr-index instr) (list 'read instr index tmp)))
+ ((mc-instr-is-written? instr vreg)
+ (hash-table-set! spills (mc-instr-index instr) (list 'write instr index tmp)))
+ (else (assert-not-reached)))
+ ;; replace vreg with tmp in instruction
+ (mc-instr-replace-vreg instr vreg tmp)
+ ;; create a range for the scratch register
+ (make-range tmp #f #f (mc-instr-index instr) (mc-instr-index instr))))
+
+(define (spill spills index cxt ranges vreg)
+ (let loop ((user* (mc-vreg-users vreg)) (ranges ranges))
+ (match user*
+ (() (remove-range vreg ranges))
+ ((user . user*)
+ (let ((tmp (add-spill spills index cxt user vreg)))
+ (loop user* (cons tmp ranges)))))))
+
(define (iterate pool ranges)
(let loop ((re* ranges)
(ac '()))
@@ -339,48 +387,64 @@
(() (list #t))
;; handle current range
((cur . re*)
- ;; (pretty-print (format-step pool cur ac re*))
- (let ((ac (expire-active pool cur ac)))
-
+ (pretty-print (format-step pool cur ac re*))
+ (let ((ac (expire-active pool cur ac)))
(cond
;; Backtrack if a spill is required
;; return (#f vreg) to indicate allocation failure
- ((pool-empty? pool)
- (list #f (range-vreg cur)))
+ ((= (pool-count pool) 0)
+ (list #f (range-vreg (select-range-to-spill ac))))
(else
;; allocate a free register
(range-hreg-set! cur (hreg-alloc pool cur))
(loop re* (update-active ac cur)))))))))
-(define (scan cxt pool ranges)
+(define (scan cxt pool spills sp-index-gen ranges)
;; enter scanning loop
(let loop ((ranges (sort ranges range-starts-before?)))
(pool-reset pool)
(match (iterate pool ranges)
((#f vreg)
;; Restart the scan after handling the spill
- ;;(loop (spill cxt ranges (spill-index-gen) vreg)))
- (pretty-print (list 'spill (vreg-name vreg))))
+ (pretty-print (list 'spill (mc-vreg-name vreg)))
+ (loop (spill spills (sp-index-gen) cxt ranges vreg)))
((#t)
- '()
+ ;; update vregs to reflect the final register assignments
+ (for-each (lambda (range)
+ (mc-vreg-hreg-set! (range-vreg range) (range-hreg range)))
+ ranges)
))))
-
-
-(define (alloc-registers-pass cxt)
- (let* ((ranges (compute-ranges cxt (build-graph cxt)))
- (pool (pool-make *regs* (fixed-ranges ranges))))
+(define (rewrite-spills cxt spills)
+ (let ((rbp (mc-context-allocate-vreg cxt 'rbp 'rbp #f)))
+ (hash-table-for-each spills
+ (lambda (k v)
+ (match v
+ (('read-write instr index vreg)
+ (mc-block-insert-before (mc-instr-block instr) instr
+ (x86-64.mov.mdr #f '() rbp (mc-make-disp (* 8 index)) vreg))
+ (mc-block-insert-after (mc-instr-block instr) instr
+ (x86-64.mov.rmd #f '() vreg rbp (make-mc-disp (* 8 index)))))
+ (('read instr index vreg)
+ (mc-block-insert-before (mc-instr-block instr) instr
+ (x86-64.mov.mdr #f '() rbp (make-mc-disp (* 8 index)) vreg)))
+ (('write instr index vreg)
+ (mc-block-insert-after (mc-instr-block instr) instr
+ (x86-64.mov.rmd #f '() vreg rbp (make-mc-disp (* 8 index))))))))))
+
+(define (alloc-registers-pass cxt regs)
+ (let* ((ranges (compute-ranges cxt (build-graph cxt)))
+ (pool (pool-make regs (fixed-ranges ranges)))
+ (spills (make-hash-table = number-hash 20))
+ (index-gen (make-count-generator)))
;; enter scanning loop
- (scan cxt pool (free-ranges ranges))
+ (scan cxt pool spills index-gen (free-ranges ranges))
- ;; update vregs to reflect the final register assignments
- (for-each (lambda (range)
- (mc-vreg-hreg-set! (range-vreg range) (range-hreg range)))
- ranges)
+ (rewrite-spills cxt spills)
;; print final assignments
- ;; (pretty-print
- ;; `(assignments ,(map (lambda (vreg)
+ ;; (pretty-print
+ ;; `(assignments ,(map (lambda (vreg)
;; `(,(mc-vreg-name vreg) ,(mc-vreg-hreg vreg)))
;; (mc-context-vregs cxt))))))
))
@@ -388,7 +452,14 @@
(define (alloc-regs mod)
(mc-context-for-each
(lambda (cxt)
- (alloc-registers-pass cxt))
+ (alloc-registers-pass cxt *regs*))
+ mod)
+ mod)
+
+(define (alloc-regs-test mod regs)
+ (mc-context-for-each
+ (lambda (cxt)
+ (alloc-registers-pass cxt regs))
mod)
mod)
View
15 machine.scm
@@ -1,6 +1,6 @@
(declare (unit machine)
- (uses nodes))
+ (uses nodes arch))
(use matchable)
(use srfi-1)
@@ -13,15 +13,15 @@
(define-struct mc-block (name head tail succ cxt))
;; instructions
-(define-struct mc-spec (name fmt fmt-indices verifiers reads writes))
-(define-struct mc-instr (spec ops next prev implicit-uses sp-load sp-store number block data))
+(define-struct mc-spec (name fmt fmt-indices verifiers reads writes))
+(define-struct mc-instr (spec ops next prev implicit-uses index block data))
;; operands
-(define-struct mc-vreg (name hreg pref users data))
+(define-struct mc-vreg (name hreg pref users data))
-(define-struct mc-imm (size value))
-(define-struct mc-disp (value))
+(define-struct mc-imm (size value))
+(define-struct mc-disp (value))
;; Constructors
@@ -35,7 +35,7 @@
(make-mc-block name '() '() '() cxt))
(define (mc-make-instr blk spec implicit-uses operands)
- (let ((instr (make-mc-instr spec operands '() '() implicit-uses '() '() #f blk '())))
+ (let ((instr (make-mc-instr spec operands '() '() implicit-uses #f blk '())))
(for-each (lambda (op)
(cond
((mc-vreg? op)
@@ -148,7 +148,6 @@
;; Printing
(define (mc-module-print mod port)
-
(fprintf port "section .text\n\n")
(fprintf port " global __scheme_exec\n\n")
(mc-context-for-each
View
2 pass.scm
@@ -5,7 +5,7 @@
(use matchable)
(use srfi-1)
-(include "struct-syntax")
+(include "struct-syntax")
;; do some macro expansion
View
47 tests/test-spill.scm
@@ -0,0 +1,47 @@
+
+(declare (uses arch machine utils liveness))
+
+(include "arch-syntax")
+
+;; create test input for spill
+
+(define (generate-test-code)
+ (let* ((mod (mc-make-module))
+ (cxt (make-mc-context 'test_spill_01 '() '() '()))
+ (blk (mc-make-block cxt 'test_spill_01)))
+ (arch-emit-code x86-64 blk
+
+ ;; prolog
+ (push.r (hreg rbp))
+ (mov.rr (hreg rsp) (hreg rbp))
+
+ ;; initialize the first three vregs to 1
+ (mov.i64r (imm i32 1) (vreg 't1))
+ (mov.i64r (imm i32 1) (vreg 't2))
+ (mov.i64r (imm i32 1) (vreg 't3))
+
+ ;; clear the fourth vreg
+ (mov.i64r (imm i64 0) (vreg 't4))
+
+ ;; add the contents of t1,t2,t3 to t4
+ (add.rr (vreg 't1) (vreg 't4))
+ (add.rr (vreg 't2) (vreg 't4))
+ (add.rr (vreg 't3) (vreg 't4))
+
+ ;; epilog: return t4 via rax (x86 calling conv)
+ (mov.rr (vreg 't4) (hreg rax))
+ (mov.rr (hreg rbp) (hreg rsp))
+ (pop.r (hreg rbp))
+ (retnear))
+
+ (mc-context-start-set! cxt blk)
+ (make-mc-module (list cxt))))
+
+(define (test-spill-01)
+ (let ((mod (generate-test-code)))
+ (alloc-regs-test mod '(rsi rdi r8))
+ (mc-module-print mod (current-output-port))))
+
+
+(test-spill-01)
+

0 comments on commit a2ac2d1

Please sign in to comment.
Something went wrong with that request. Please try again.