Skip to content
Browse files

Added a rough implementation of a linear scan allocator

  • Loading branch information...
1 parent aa9bf7d commit b3931a9cb10e139c3393e95d55b52b3c753a57e0 @vgeddes committed
Showing with 761 additions and 377 deletions.
  1. +60 −12 arch-syntax.scm
  2. +6 −4 arch.scm
  3. +123 −59 arch/x86-64/arch-x86-64.scm
  4. +25 −24 arch/x86-64/rules-x86-64.scm
  5. +60 −57 arch/x86-64/spec-x86-64.scm
  6. +368 −140 liveness.scm
  7. +78 −40 machine.scm
  8. +3 −2 main.scm
  9. +11 −5 munch-syntax.scm
  10. +2 −2 nodes.scm
  11. +23 −30 pass.scm
  12. +1 −1 tests/simple-002.scm
  13. +1 −1 tree.scm
View
72 arch-syntax.scm
@@ -10,6 +10,33 @@
(define-syntax define-arch-instructions
(lambda (e r c)
+
+ (define (parse-fmt fmt)
+ (let* ((pos-1 (cons 1 (string-contains fmt "$1")))
+ (pos-2 (cons 2 (string-contains fmt "$2")))
+ (pos-3 (cons 3 (string-contains fmt "$3")))
+ (pos-4 (cons 4 (string-contains fmt "$4")))
+ (lst (list pos-1 pos-2 pos-3 pos-4))
+ (lst-filtered (fold (lambda (pos x)
+ (if (cdr pos)
+ (cons pos x)
+ x))
+ '()
+ lst))
+ (sorted (sort lst-filtered
+ (lambda (p1 p2)
+ (< (cdr p1) (cdr p2)))))
+ (indices (map (lambda (p) (car p)) sorted))
+ (fmt
+
+ (let f ((fmt fmt) (p* sorted))
+ (match p*
+ (() fmt)
+ ((p . p*)
+ (f (string-replace fmt "~a" (cdr p) (+ (cdr p) 2)) p*))))))
+
+ (cons fmt indices)))
+
;; operand types
;; i8 8-bit immediate
;; i32 32-bit immediate
@@ -51,7 +78,7 @@
`(lambda (ops) (append ,@(reverse accessors))))
((flag . flag*)
(let ((accessors (if flag
- (cons `(mc-operand-vregs (,(accessor i) ops)) accessors)
+ (cons `(list (,(accessor i) ops)) accessors)
accessors)))
(f flag* (+ i 1) accessors))))))
@@ -93,29 +120,39 @@
(define (gen-instr-spec arch name fmt operand-spec*)
(let* ((spec (string->symbol (format "~s.~s-spec" arch name)))
(predicate (string->symbol (format "~s.~s?" arch name)))
+ (qualified-name (string->symbol (format "~s.~s" arch name)))
(operand-info (parse-operand-specs operand-spec*))
+ (fmt-info (parse-fmt fmt))
+ (fmt (car fmt-info))
+ (fmt-indices (cdr fmt-info))
(verifiers (first operand-info))
(vregs-read (gen-accessor (second operand-info)))
(vregs-written (gen-accessor (third operand-info)))
(%define (r 'define))
(%lambda (r 'lambda))
(%let (r 'let))
+ (%match (r 'match))
(%mc-make-instr (r 'mc-make-instr))
(%make-mc-spec (r 'make-mc-spec)))
+
`((,%define ,spec
(,%make-mc-spec
',name
',fmt
+ ',fmt-indices
',verifiers
,vregs-read
,vregs-written))
(,%define ,predicate
(,%lambda (x)
(and (mc-instr? x) (eq? (mc-instr-spec x) ,spec))))
- (,%define ,name
+ (,%define ,qualified-name
(,%lambda operands
- (mc-make-instr ,spec operands))))))
+ (,%match operands
+ ((block56 implicit-uses56 rest56* ...)
+ (,%mc-make-instr block56 ,spec implicit-uses56 rest56*))
+ (else (assert-not-reached))))))))
(match e
(('define-arch-instructions arch spec* ...)
@@ -130,7 +167,15 @@
`(,%begin
,@code))))))
-;; Convenience macro for manual code emission
+(define-syntax define-arch-registers
+ (lambda (e r c)
+ (match e
+ (('define-arch-registers arch (reg* ...))
+ (let ((def (string->symbol (format "~s-registers" arch))))
+ `(define ,def ',reg*))))))
+
+
+;; Convenience macro for building assembly code
(define-syntax arch-emit-code
(lambda (e r c)
@@ -138,25 +183,28 @@
(define (expand blk e)
(let ((%mc-context-allocate-vreg (r 'mc-context-allocate-vreg))
(%mc-block-cxt (r 'mc-block-cxt))
- (%mc-make-imm (r 'mc-make-imm))
- (%mc-make-disp (r 'mc-make-disp)))
-
+ (%make-mc-imm (r 'make-mc-imm))
+ (%make-mc-disp (r 'make-mc-disp)))
(match e
- ((e1* ...)
- (map (lambda (e) (expand blk e)) e1*))
(('vreg x)
`(,%mc-context-allocate-vreg (,%mc-block-cxt ,blk) ,x))
+ (('vreg x ('constraint r))
+ `(,%mc-context-allocate-vreg (,%mc-block-cxt ,blk) ,x ',r))
+ (('hreg x)
+ `(,%mc-context-allocate-vreg (,%mc-block-cxt ,blk) ',x ',x))
(('imm size x)
- `(,%mc-make-imm ,size ,x))
+ `(,%make-mc-imm ',size ,x))
(('disp x)
- `(,%mc-make-disp ,x))
+ `(,%make-mc-disp ,x))
+ ((op* ...)
+ (map (lambda (op) (expand blk op)) op*))
(_ e))))
(define (generate arch blk instr)
(let ((qualified-name (string->symbol (format "~s.~s" arch (car instr)))))
(match instr
((name operands* ...)
- `(,qualified-name ,blk ,@(expand blk operands*))))))
+ `(,qualified-name ,blk '() ,@(expand blk operands*))))))
(match e
(('arch-emit-code arch blk x* ...)
View
10 arch.scm
@@ -2,22 +2,21 @@
(uses nodes arch-x86-64))
-
;; The default selected architecture
(define *arch* <arch-x86-64>)
;; Get all vregs that are read in this instr
(define (arch-vregs-read instr)
- ((arch-descriptor-vregs-read) instr))
+ ((arch-descriptor-vregs-read *arch*) instr))
;; Get all vregs that are written to in this instr
(define (arch-vregs-written instr)
- ((arch-descriptor-vregs-written) instr))
+ ((arch-descriptor-vregs-written *arch*) instr))
;; Generate a function to act as a bridge between the C runtime and the compiled Scheme.
;;
(define (arch-generate-bridge-context mod)
- ((arch-descriptor-generate-bridge *arch*) mod))
+ ((arch-descriptor-generate-bridge-context *arch*) mod))
;; Format an operand
;;
@@ -29,5 +28,8 @@
(define (arch-emit-statement mc-blk tree)
((arch-descriptor-emit-statement *arch*) mc-blk tree))
+(define (arch-make-context name params mod)
+ ((arch-descriptor-make-context *arch*) name params mod))
+
View
182 arch/x86-64/arch-x86-64.scm
@@ -1,25 +1,58 @@
(declare (unit arch-x86-64)
- (uses spec-x86-64 rules-x86-64 tree nodes))
+ (uses machine spec-x86-64 rules-x86-64 tree nodes))
(use matchable)
(use srfi-1)
(include "arch-syntax")
+(define *tail-call-hregs-x86-64* '(r8 r9 r10 r11 r12 r13 r14 r15))
+
+;;
+;; Arguments passed to a context are constrained to registers r8 ... r15.
+;; This could cause allocation conflicts between constrained vregs during register allocation.
+;;
+;; So we insert moves to copy each constrained arg into an unconstrained vreg, and add
+;; hints so that the allocator can eliminate the move if possible
+;;
+(define (make-context-x86-64 name params mod)
+ (let* ((cxt (make-mc-context name '() '() '()))
+ (args (map (lambda (param hint)
+ (mc-make-vreg param hint))
+ params
+ *tail-call-hregs-x86-64*))
+ (args-fixed (map (lambda (arg hreg)
+ (mc-context-allocate-vreg cxt (gensym 't) hreg))
+ args
+ *tail-call-hregs-x86-64*))
+ (blk (mc-make-block cxt name)))
+
+ ;; insert move from each arg-fixed into arg
+ (for-each (lambda (fixed arg)
+ (arch-emit-code x86-64 blk
+ (mov.rr fixed arg)))
+ args-fixed args)
+
+ (mc-context-start-set! cxt blk)
+ (mc-context-args-set! cxt args-fixed)
+ (mc-module-contexts-set! mod (cons cxt (mc-module-contexts mod)))
+ cxt))
+
+
(define (operand-format-x86-64 op)
(cond
((mc-vreg? op)
- (format "%~s" name))
+ (format "~s" (mc-vreg-name op)))
((mc-imm? op)
- (format "~s" value))
+ (format "~s" (mc-imm-value op)))
((mc-disp? op)
- (format "~s" value))
+ (format "~s" (mc-disp-value op)))
(else (assert-not-reached))))
(define (vregs-read-x86-64 instr)
- (let ((ops (mc-instr-ops instr))
- (reads ((mc-spec-vregs-read (mc-instr-spec instr)) ops)))
+ (let* ((ops (mc-instr-ops instr))
+ (reads ((mc-spec-reads (mc-instr-spec instr)) ops)))
(cond
((x86-64.xor.rr? instr)
(cond
@@ -29,8 +62,8 @@
(else reads))))
(define (vregs-written-x86-64 instr)
- (let ((ops (mc-instr-ops instr))
- (writes ((mc-spec-written (mc-instr-spec instr)) ops)))
+ (let* ((ops (mc-instr-ops instr))
+ (writes ((mc-spec-writes (mc-instr-spec instr)) ops)))
writes))
@@ -41,81 +74,111 @@
(cond
((tree-constant? value)
(case (tree-constant-size value)
- ((i64)
+ ((i32)
(arch-emit-code x86-64 block
- (xor64.rr (vreg 'rax) (vreg 'rax)))
- (mov64.i64r (imm i64 (tree-constant-value value)) (vreg 'rax)))
+ (mov.i64r (imm i64 0) (hreg rax))
+ (mov.i32r (imm i32 (tree-constant-value value)) (hreg rax))))
+ ((i64)
+ (arch-emit-code x86-64 block
+ (mov.i64r (imm i64 (tree-constant-value value)) (hreg rax))))
(else (assert-not-reached))))
((tree-temp? value)
(arch-emit-code x86-64 block
- (mov.rr (vreg (tree-temp-name value)) (vreg 'rax)))))
+ (mov.rr (vreg (tree-temp-name value)) (hreg rax)))))
;; stack frame management
(arch-emit-code x86-64 block
- (mov64rr (vreg 'rbp) (vreg 'rsp))
- (pop64r (vreg 'rbp))
+ (mov.rr (hreg rbp) (hreg rsp))
+ (pop.r (hreg rbp))
(retnear)))
;;
;; Lower tail calls to x86-64 code
;;
-;; * Only immediates and virtual registers are allowed as arguments (i.e. no memory references). Memory
-;; loads will have been performed in an earlier on the control path.
-;; * can only jump to labels or values contained in virtual registers
-;;
-;; The above rules may be revised as we improve instruction selection (i.e merging selection trees for better selection opportunities)
+;; * Only immediates virtual registers are allowed as arguments (i.e. no memory references).
+;; * Can only jump to labels or values contained in virtual registers
;;
-;; We move each positional arg to a constrained temp
-;; Each temp will be constrained to a standard argument-passing register
+;; We move each positional arg to a constrained temp (i.e pre-colored to a hardware register)
+
;; Standard argument passing registers (in order): r8 r9 r10 r11 r12 r13 14 r15
;;
-;; We create a selection tree for each arg so we can produce efficient code for moving the arg
+;; We create a selection tree for each move so we can produce efficient code for moving the arg
;; to the constrained temp. This is mostly useful for immediate -> register moves.
;;
;; Example:
;;
-;; lower (app fib45 (t5 t67 3 t34)) =>
+;; lower (call fib45 (t5 t67 3 t34)) =>
;;
-;; movq t5, r8
-;; movq t67, r9
-;; movq 3, r10
-;; movq 34, r11
-;;
-;; jmp fib45(%rip) # relative jmp to fib45
+;; mov r8, t5
+;; mov r9, t67
+;; mov r10, 3
+;; mov r11, t34
+;; jmp [rip + fib45] # relative jmp to fib45.
;;
-(define (emit-tail-call-x86-64 block target args)
-
- (let* ((constrained-temps (let f ((arg* args) (constrained-reg '(r8 r9 r10 r11 r12 r13 r14 r15)) (x '()))
- (match arg*
- (() (reverse x))
- ((arg . arg*)
- (f arg* (cdr constrained-reg) (cons (car constrained-reg) x))))))
- (arg-tree* (map (lambda (arg constrained-temp)
- (tree-make-assign constrained-temp arg))
- args
- constrained-temps)))
-
- ;; Select instructions for moving args to constrained temps
- (for-each (lambda (arg-tree)
- (munch-x86-64 block arg-tree))
- arg-tree*)
+;; For liveness analysis and register allocation purposes, we hint that 'jmp' implicitly uses r8, r9, r10 and r11
+;;
+(define (emit-tail-call-x86-64 blk tgt args)
+
+ (define (lower-target tgt)
+ (cond
+ ((tree-label? tgt)
+ (mc-make-disp (tree-label-name tgt)))
+ ((tree-temp? tgt)
+ (mc-context-allocate-vreg (mc-block-cxt blk) (tree-temp-name tgt)))
+ (else (assert-not-reached))))
+
+ (let* ((hregs '(r8 r9 r10 r11 r12 r13 r14 r15))
+ (hregs-used (let f ((arg* args) (hregs hregs) (x '()))
+ (match arg*
+ (() (map (lambda (hreg) (mc-context-allocate-vreg (mc-block-cxt blk) hreg hreg)) (reverse x)))
+ ((arg . arg*)
+ (f arg* (cdr hregs) (cons (car hregs) x))))))
+ (moves* (map (lambda (hreg arg)
+ (tree-make-assign hreg arg))
+ hregs-used
+ args)))
- ;; Select instruction for the branch
- (munch-x86-64 block (tree-make-br target))))
-
+ ;; Select instructions for each move
+ (for-each (lambda (reg arg)
+ (pretty-print (mc-vreg-name reg))
+ (cond
+ ((tree-temp? arg)
+ (arch-emit-code x86-64 blk
+ (mov.rr (vreg (tree-temp-name arg)) reg)))
+ ((tree-constant? arg)
+ (arch-emit-code x86-64 blk
+ (mov.i64r (imm i64 (tree-constant-value arg)) reg)))
+ (else (assert-not-reached))))
+ hregs-used args)
+
+ ;; Choose instruction for the actual tail call
+ (cond
+ ((tree-label? tgt)
+ (x86-64.jmp.d blk hregs-used (lower-target tgt)))
+ ((tree-temp? tgt)
+ (x86-64.jmp.r blk hregs-used (lower-target tgt)))
+ (else (assert-not-reached)))))
(define (generate-bridge-context-x86-64 mod)
- (let ((cxt (mc-make-cxt mod (list 'heap_ptr)))
- (blk (mc-make-block cxt '__scheme_exec'))
- (heap_ptr (mc-context-allocate-vreg cxt 'heap_ptr)))
+ (let* ((cxt (make-mc-context '__scheme_exec '() '() '()))
+ (ptr (mc-context-allocate-vreg cxt (gensym 't) 'rsi)))
- (arch-emit-code x86-64 blk
- ;; prologue
- (push.r (vreg 'rbp)))
- (mov.rr (vreg 'rsp) (vreg 'rbp))
+ (mc-context-args-set! cxt (list ptr))
+ (mc-context-start-set! cxt (mc-make-block cxt '__scheme_exec))
+
+ (arch-emit-code x86-64 (mc-context-start cxt)
+ ;; prologue
+ (push.r (hreg rbp))
+ (mov.rr (hreg rsp) (hreg rbp))
;; set heap_ptr
- (mov.rm heap_ptr (disp 'heap_ptr))))
+ (mov.rd ptr (disp 'heap_ptr))
+ ;; jump to __begin
+ (jmp.d (disp 'begin)))
+
+ (mc-module-contexts-set! mod (cons cxt (mc-module-contexts mod)))
+
+ cxt))
;; Selects x86-64 instructions for a tree node
@@ -127,7 +190,7 @@
(($ tree-instr 'call _ target args)
(case (tree-instr-attr tree 'callconv)
((tail)
- (emit-tail-call block target args))
+ (emit-tail-call-x86-64 block target args))
((cdecl) '())
(else (error 'munch-statement "should not reach here"))))
(($ tree-instr 'assign _ (? symbol?) ($ tree-instr 'call) _ _ _ _ attrs) '())
@@ -135,9 +198,10 @@
(define <arch-x86-64>
(make-arch-descriptor
+ make-context-x86-64
operand-format-x86-64
vregs-read-x86-64
- vregs-written-86-64
- generate-bridge-x86-64
+ vregs-written-x86-64
+ generate-bridge-context-x86-64
emit-statement-x86-64))
View
49 arch/x86-64/rules-x86-64.scm
@@ -1,29 +1,31 @@
(declare (unit rules-x86-64)
- (uses tree))
+ (uses tree machine))
(include "munch-syntax")
(include "arch-syntax")
+(use matchable)
+
(define-munch-rules x86-64
;; branch to label
((br (label x))
(temps) (out)
- ((jmp64.d (disp x))))
+ ((jmp.d (disp x))))
;; branch indirect
((br (temp x))
(temps) (out)
- ((jmp64.r (vreg x))))
+ ((jmp.r (vreg x))))
;; branch if true
((brc op1 (label tl) (label fl))
(temps) (out)
((cmp.i8r (imm i8 0) op1)
- (jne.d disp tl)))
+ (jne.d (disp tl))))
;; branch if >
@@ -76,7 +78,7 @@
((cmp (mode i64) (op le) op1 op2)
(temps t1) (out t1)
- ((xor.rr t1 t1)
+ ((mov.i64r (imm i64 0) t1)
(cmp.rr op1 op2)
(setle.r t1)))
@@ -84,7 +86,7 @@
((cmp (mode i64) (op lt) op1 op2)
(temps t1) (out t1)
- ((xor.rr t1 t1)
+ ((mov.i64r (imm i64 0) t1)
(cmp.rr op1 op2)
(setl.r t1)))
@@ -92,7 +94,7 @@
((cmp (mode i64) (op eq) op1 op2)
(temps t1) (out t1)
- ((xor.rr t1 t1)
+ ((mov.i64r (imm i64 0) t1)
(cmp.rr op1 op2)
(sete.r t1)))
@@ -100,7 +102,7 @@
((cmp (mode i64) (op gt) op1 op2)
(temps t1) (out t1)
- ((xor.rr t1 t1)
+ ((mov.i64r (imm i64 0) t1)
(cmp.rr op1 op2)
(setg.r t1)))
@@ -108,7 +110,7 @@
((cmp (mode i64) (op ge) op1 op2)
(temps t1) (out t1)
- ((xor.rr t1 t1)
+ ((mov.i64r (imm i64 0) t1)
(cmp.rr op1 op2)
(setge.r t1)))
@@ -116,27 +118,27 @@
((load (mode ptr64) (label l1))
(temps t1) (out t1)
- ((lea.mr (disp l1) t1)))
+ ((lea.dr (disp l1) t1)))
((assign (temp x) (load (mode ptr64) (label l1)))
(temps) (out)
- ((lea.mr (disp l1) (vreg x))))
+ ((lea.dr (disp l1) (vreg x))))
;; load immediate
((const i8 x)
(temps t1) (out t1)
- ((xor.rr t1 t1)
- (mov64i8r (imm i8 x) t1)))
+ ((mov.i64r (imm i64 0) t1)
+ (mov.i8r (imm i8 x) t1)))
((const i32 x)
(temps t1) (out t1)
- ((xor.rr t1 t1)
- (mov64i32r (imm i32 x) t1)))
+ ((mov.i64r (imm i64 0) t1)
+ (mov.i32r (imm i32 x) t1)))
((const i64 x)
(temps t1) (out t1)
- ((mov64i64r (imm i64 x) t1)))
+ ((mov.i64r (imm i64 x) t1)))
;; memory load
@@ -163,18 +165,17 @@
(temp t1)
(const i32 c1)))
(temps) (out)
- ((mov64rm (vreg x)
- (addr (base (vreg t1)) (disp c1)))))
+ ((mov.rmd (vreg x) (vreg t1) (disp c1))))
((store (mode i64) op1 (add (mode i32)
(temp t1)
(const i32 c1)))
(temps) (out)
- ((mov64rm op1 (addr (base (vreg t1)) (disp c1)))))
+ ((mov.rmd op1 (vreg t1) (disp c1))))
((store (mode i64) op1 (label l1))
(temps) (out)
- ((mov64rm op1 (addr (disp l1)))))
+ ((mov.rd op1 (disp l1))))
;; assign
@@ -268,17 +269,17 @@
((ior (mode i64) op1 (const i8 x))
(temps t5) (out t5)
((mov.rr op1 t5)
- (or.i8r (imm i8 x) t5)))
+ (ior.i8r (imm i8 x) t5)))
((ior (mode i64) (const i8 x) op2)
(temps t5) (out t5)
((mov.rr op2 t5)
- (or.i8r (imm i8 x) t5)))
+ (ior.i8r (imm i8 x) t5)))
((ior (mode i64) op1 (const i32 x))
(temps t5) (out t5)
((mov.rr op1 t5)
- (or.i32r (imm i32 x) t5)))
+ (ior.i32r (imm i32 x) t5)))
((ior (mode i64) (const i32 x) op2)
(temps t5) (out t5)
@@ -288,7 +289,7 @@
((ior (mode i64) op1 op2)
(temps t5) (out t5)
((mov.rr op2 t5)
- (or.rr op1 t5)))
+ (ior.rr op1 t5)))
;; xor
View
117 arch/x86-64/spec-x86-64.scm
@@ -1,8 +1,11 @@
(declare (unit spec-x86-64)
- (uses nodes))
+ (uses nodes machine))
(include "arch-syntax")
+(use matchable)
+(use srfi-1)
+
;; Instruction Definitions
;; operand flags
@@ -20,7 +23,7 @@
;; in register is read
;; out register is modified
-;;(registers (rsp rbp rsi rdi rax rbx rcx rdx r8 r9 r10 r11 r12 r13 r14 r15))
+(define-arch-registers x86-64 (rsp rbp rsi rdi rax rbx rcx rdx r8 r9 r10 r11 r12 r13 r14 r15))
(define-arch-instructions x86-64
@@ -34,244 +37,244 @@
(push.r
((reg in))
- "pushq $1")
+ "push $1")
;; pop
(pop.r
((reg out))
- "popq $2")
+ "pop $1")
;; lea
(lea.mr
((reg in) (reg out))
- "leaq $1, $2")
+ "lea $2, [$1]")
(lea.dr
- ((disp32 in) (reg out))
- "leaq $1(%rip), $2")
+ ((disp32) (reg out))
+ "lea $2, [rip + $1]")
(lea.mdr
- ((reg in) (disp32 in) (reg out))
- "leaq $2($1), $3")
+ ((reg in) (disp32) (reg out))
+ "lea $3, [$1 + $2]")
;; call
(call.d
((disp32))
- "call $1(%rip)")
+ "call [rip + $1]")
;; add
(add.rr
((reg in) (reg in out))
- "addq $1, $2")
+ "add $2, $1")
(add.i8r
((i8) (reg in out))
- "addq $1, $2")
+ "add $2, 1$")
(add.i32r
((i32) (reg in out))
- "addq $1, $2")
+ "add $2, $1")
;; sub
(sub.rr
((reg in) (reg in out))
- "subq $1, $2")
+ "sub $2, $1")
(sub.i8r
((i8) (reg in out))
- "subq $1, $2")
+ "sub $2, $1")
(sub.i32r
((i32) (reg in out))
- "subq $1, $2")
+ "sub $2, $1")
;; and
(and.rr
((reg in) (reg in out))
- "andq $1, $2")
+ "and $2, $1")
(and.i8r
((i8) (reg in out))
- "andq $1, $2")
+ "and $2, $1")
(and.i32r
((i32) (reg in out))
- "andq $1, $2")
+ "and $2, $1")
;; or
(ior.rr
((reg in) (reg in out))
- "orq $1, $2")
+ "or $2, $1")
(ior.i8r
((i8) (reg in out))
- "orq $1, $2")
+ "or $2, $1")
(ior.i32r
((i32) (reg in out))
- "orq $1, $2")
+ "or $2, $1")
;; xor
(xor.rr
((reg in) (reg in out))
- "xorq $1, $2")
+ "xor $2, $1")
(xor.i32r
((i32) (reg in out))
- "xorq $1, $2")
+ "xor $2, $1")
;; shr
(shr.i8r
((i8) (reg in out))
- "shrq $1, $2")
+ "shr $2, $1")
;; shl
(shl.i8r
((i8) (reg in out))
- "shlq $1, $2")
+ "shl $2, $1")
;; mov
(mov.rr
((reg in) (reg out))
- "movq $1, $2")
+ "mov $2, $1")
(mov.rd
((reg in) (disp32))
- "movq $1, $2(%rip)")
+ "mov [rip + $2], $1")
(mov.rm
((reg in) (reg in))
- "movq $1, ($2)")
+ "mov [$2], $1")
(mov.rmd
((reg in) (reg in) (disp32))
- "movq $1, $3($2)")
+ "mov [$2 + $3], $1")
(mov.dr
((disp32) (reg out))
- "movq $1(%rip), $2")
+ "mov $2, [rip + $1]")
(mov.mr
((reg in) (reg out))
- "movq ($1), $2")
+ "mov $2, [$1]")
(mov.mdr
((reg in) (disp32) (reg out))
- "movq $2($1), $3")
+ "mov $3, [$1 + $2]")
(mov.i8r
((i8) (reg out))
- "movq $1, $2")
+ "mov $2, $1")
(mov.i32r
((i32) (reg out))
- "movq $1, $2")
+ "mov $2, $1")
(mov.i64r
((i64) (reg out))
- "movq $1, $2")
+ "mov $2, $1")
;; setCC
(sete.r
((reg out))
- "sete $1")
+ "sete $1")
(setne.r
((reg out))
- "setne $1")
+ "setne $1")
(setl.r
((reg out))
- "setl $1")
+ "setl $1")
(setle.r
((reg out))
- "setle $1")
+ "setle $1")
(setg.r
((reg out))
- "setg $1")
+ "setg $1")
(setge.r
((reg out))
- "setge $1")
+ "setge $1")
;; cmp
(cmp.rr
((reg in) (reg in))
- "cmpq $1, $2")
+ "cmp $2, $1")
(cmp.i8r
((i8) (reg in))
- "cmpq $1, $2")
+ "cmp $2, $1")
(cmp.i32r
((i32) (reg in))
- "cmpq $1, $2")
+ "cmp $2, $1")
;; jmp
(jmp.d
((disp32))
- "jmp $1(%rip)")
+ "jmp [rip + $1]")
(jmp.r
((reg in))
- "jmp $1")
+ "jmp $1")
(jmp.m
((reg in))
- "jmp ($1)")
+ "jmp [$1]")
(jmp.md
((reg in) (disp32))
- "jmp $2($1)")
+ "jmp [$1 + $2]")
;; jCC
(jo.d
((disp32))
- "jo $1(%rip)")
+ "jo [rip + $1]")
(jno.d
((disp32))
- "jno $1(%rip)")
+ "jno [rip + $1]")
(je.d
((disp32))
- "je $1(%rip)")
+ "je [rip + $1]")
(jne.d
((disp32))
- "jne $1(%rip)")
+ "jne [rip + $1]")
(jl.d
((disp32))
- "jl $1(%rip)")
+ "jl [rip + $1]")
(jle.d
((disp32))
- "jle $1(%rip)")
+ "jle [rip + $1]")
(jge.d
((disp32))
- "jge $1(%rip)")
+ "jge [rip + $1]")
(jg.d
((disp32))
- "jg $1(%rip)"))
+ "jg [rip + $1]"))
View
508 liveness.scm
@@ -1,6 +1,6 @@
(declare (unit liveness)
- (uses nodes mc utils))
+ (uses nodes machine utils))
(use matchable)
(use srfi-1)
@@ -8,175 +8,403 @@
(include "struct-syntax")
(include "munch-syntax")
-(define (build-cfg context)
+(define assert-not-reached
+ (lambda ()
+ (error 'assert-not-reached)))
+
+(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 (format-range range)
+ `(range ,(mc-vreg-name (range-vreg range))
+ ,(range-hreg range)
+ ,(range-start range)
+ ,(range-end range)))
+
+(define (format-step hregs-free current active fixed rest)
+ `(step ,(range-start step)
+ (hregs-free ,hregs-unused)
+ (current ,(format-range current))
+ (active ,@(map (lambda (range) (format-range range)) active))
+ (fixed ,@(map (lambda (range) (format-range range)) fixed))
+ (rest ,@(map (lambda (range) (format-range range)) rest))))
- (define (make-block block counter)
+;;
+;; Build a control-flow DAG for the given context. The graph is used for live variable analysis.
+;;
+;; The graph abstracts away from basic blocks. Each node represents an individual instruction.
+;; Multiple outgoing edges on a node indicate a branching decision.
+;;
+(define (build-graph cxt)
+
+ (define (walk block counter)
(match block
- (($ mc-block name head tail (successor* ...) cxt)
+ (($ mc-block name head tail (succ* ...) cxt)
(let* ((nodes (let f ((instr head) (nodes '()))
(cond
- ((null? instr)
- (reverse nodes))
+ ((null? instr) (reverse nodes))
(else
- (f (mc-instr-next instr)
- (cons (make-node (counter) 'instr instr '() '()) nodes))))))
- (head
- (car nodes))
+ (let ((number (counter)))
+ (mc-instr-number-set! instr number)
+ (f (mc-instr-next instr)
+ (cons (make-node number instr '() '() '() '() '() '() '()) nodes)))))))
+ (head (car nodes))
(tail (car (reverse nodes)))
- (successors
- (map (lambda (succ)
- (make-block succ counter))
- successor*))
- (basic-block
- (make-node (counter) 'block name '() (list head))))
+ (succ (map (lambda (succ)
+ (walk succ counter))
+ succ*)))
- (let f ((cur (car nodes)) (rest (cdr nodes)))
- (match rest
+ ;; set next/prev pointers
+ (let f ((cur (car nodes)) (node* (cdr nodes)))
+ (match node*
(() cur)
- ((r . r*)
- (node-succ-set! cur (list r))
- (node-pred-set! r (list cur))
- (f r r*))))
-
- (node-succ-set! tail successors)
-
- ;; set predecessor pointers
- (for-each (lambda (successor)
- (node-pred-set! successor (list tail)))
- successors)
- basic-block))))
+ ((node . node*)
+ (node-succ-set! cur (list node))
+ (node-pred-set! node (list cur))
+ (f node node*))))
- (struct-case context
- ((mc-context name args start vreg-pool)
- (make-block start (make-count-generator)))))
+ (node-succ-set! tail succ)
+ ;; make successors point back to tail
+ (for-each (lambda (node)
+ (node-pred-set! node (list tail)))
+ succ)
+ head))))
-(define assert-not-reached
- (lambda (proc . irritants)
- (apply error `(assert-not-reached ,proc ,@irritants))))
-
+ (walk (mc-context-start cxt) (make-count-generator)))
-(define (sort-reverse-pre-order node)
+;;
+;; Sort the graph nodes using a reverse pre-ordering
+;;
+;; Given the graph, with each node numbered from 1 to 6:
+;; 1 --> 2 --> 3 --> 4
+;; \
+;; --> 5 --> 6
+;;
+;; The result is: 6 5 4 3 2 1
+;;
+(define (sort-reverse-pre-order graph)
(define (walk node)
(cons node (apply append (map walk (node-succ node)))))
- (reverse (walk node)))
-
-
-(define (def-use-at node)
- (cond
- ((eq? (node-type node) 'block)
- (values '() '()))
- (else
- (mc-instr-def-use (node-value node)))))
-
+ (reverse (walk graph)))
-(define (vreg-eq? v1 v2)
- (eq? (mc-vreg-name v1) (mc-vreg-name v2)))
+;; Get all vregs defined at the given node
+(define (def-at node)
+ (mc-instr-vregs-written (node-value node)))
-(define (analyze-liveness cfg)
+;; Get all vregs used at the given node
+(define (use-at node)
+ (append (mc-instr-vregs-read (node-value node)) (mc-instr-implicit-uses (node-value node))))
- (let* ((node* (sort-reverse-pre-order cfg))
- (len (length node*))
- (in (make-vector len '()))
- (out (make-vector len '()))
- (def (make-vector len '()))
- (use (make-vector len '())))
+;; Perform iterative liveness analysis on the graph
+;;
+;; We define the following sets for each node:
+;; def: Set of vregs defined at this node
+;; use: Set of vregs used at this node
+;; in: Set of vregs that are live just before this node
+;; out: Set of vregs that are live just after this node
+;;
+;; The analysis takes place on a reverse pre-ordering of the graph nodes.
+;; (i.e from the last node to the first node)
+;;
+(define (analyze-liveness graph)
+ (let ((node* (sort-reverse-pre-order graph)))
+ ;; initialize def/use for each node
(for-each
(lambda (node)
- (let-values (((defs uses) (def-use-at node)))
- (vector-set! def (node-id node) defs)
- (vector-set! use (node-id node) uses)))
- node*)
+ (node-def-set! node (def-at node))
+ (node-use-set! node (use-at node)))
+ node*)
+ ;; iterate over nodes (backwards) to propagate uses.
(for-each
- (lambda (node)
- (vector-set! out (node-id node)
- (fold (lambda (succ acc)
- (append (vector-ref in (node-id succ)) acc))
+ (lambda (node)
+ ;; node[i].out = node[i+1].in
+ (node-out-set! node
+ (fold (lambda (succ acc)
+ (append (node-in succ) acc))
'()
- (node-succ node)))
- (vector-set! in (node-id node)
- (lset-union vreg-eq?
- (vector-ref use (node-id node))
- (lset-difference vreg-eq?
- (vector-ref out (node-id node))
- (vector-ref def (node-id node))))))
- node*)
+ (node-succ node)))
+ ;; node[i].in = node[i].use UNION (node[i].out MINUS node[i].def)
+ (node-in-set! node
+ (lset-union mc-vreg-equal?
+ (node-use node)
+ (lset-difference mc-vreg-equal?
+ (node-out node)
+ (node-def node)))))
+ node*)
+ ;; final set of live variables at each point is (node[i].in UNION node[i].def)
(for-each
(lambda (node)
- (cond
- ((eq? (node-type node) 'instr)
- (mc-instr-data-set! (node-value node)
- (lset-union vreg-eq? (vector-ref in (node-id node))
- (vector-ref def (node-id node)))))))
+ (node-live-set! node
+ (lset-union mc-vreg-equal? (node-in node) (node-def node))))
node*)
+ graph))
- ))
+;; Determines whether live range r1 starts before r2
+;;
+(define (range-starts-before? r1 r2)
+ (< (range-start r1) (range-start r2)))
-(define (analyze-liveness-pass mod)
- (struct-case mod
- ((mc-module contexts)
- (let ((cfg* (map build-cfg contexts)))
- (for-each analyze-liveness cfg*)
- mod))))
+;; Determines whether live range r1 ends before r2
+;;
+(define (range-ends-before? r1 r2)
+ (< (range-end r1) (range-end r2)))
-(define-struct info (name range data))
+;; Determines whether r1 and r2 overlap
+;; TODO: we can surely remove redundant tests here
+(define (ranges-overlap? r1 r2)
+ (cond
+ ((or (<= (range-end r1) (range-start r2)) (<= (range-end r2) (range-start r1)))
+ #f)
+ ;; r1 0----5
+ ;; r2 3--6
+ ((and (>= (range-start r2) (range-start r1)) (<= (range-start r2) (range-end r1)))
+ #t)
+ ;; r1 0----5
+ ;; r2 1-3
+ ((and (<= (range-start r1) (range-start r2)) (>= (range-end r1) (range-end r2)))
+ #t)
+ ;; r1 1-3
+ ;; r2 0----5
+ ((and (>= (range-start r1) (range-start r2)) (<= (range-start r1) (range-end r2)))
+ #t)
+ ;; r1 1--5
+ ;; r2 0--3
+ ((and (>= (range-start r1) (range-start r2)) (<= (range-start r1) (range-end r2)))
+ #t)
+ (else #f)))
-(define (allocate-registers-pass mod)
+;;
+;; Compute live ranges for each vreg in the context
+;;
+(define (compute-live-ranges cxt graph)
- (define *temp-info* '())
+ (analyze-liveness graph)
- (define (temp-info tmp)
- (cond
- ((assq tmp *temp-info*) => cdr)
- (else
- (let ((info (make-info tmp (cons -1 -1) '())))
- (set! *temp-info* (cons (cons tmp info) *temp-info*))
- info))))
+ ;; update live ranges at node
+ (define (update node)
+ (for-each
+ (lambda (vreg)
+ (let ((range (mc-vreg-data vreg))
+ (index (node-index node)))
+ (cond
+ ((null? range)
+ (mc-vreg-data-set! vreg (make-range vreg #f (mc-vreg-constraint vreg) index index)))
+ (else
+ (range-end-set! range index)))))
+ (node-live node)))
+
+ (let walk ((node graph))
+ (match node
+ (() '())
+ (_
+ (update node)
+ (for-each (lambda (succ)
+ (walk succ))
+ (node-succ node)))))
- (define (analyze-defs block)
- (match block
- (('block name (successor* ...) (instr* ...))
- (apply lset-union
- (cons vreg-eq? (append (map (lambda (instr)
- (instr-def-list instr))
- instr*)
- (map analyze-defs successor*)))))))
-
- (define (compute-live-range-for-temp temp start)
- (let f ((block start) (id-gen (make-count-generator)))
- (match block
- (('block name (successor* ...) (instr* ...))
- (let g ((i* instr*))
- (match i*
- (() '())
- ((i . i*)
- (let ((id (id-gen)))
- (cond
- ((memq temp (instr-data i))
- (let ((info (temp-info temp)))
- (match (info-range info)
- ((start . end)
- (if (< start 0)
- (info-range-set! info (cons id end)))
- (if (> id end)
- (info-range-set! info (cons (car (info-range info)) id)))))))))
- (g i*))))
- (for-each (lambda (block)
- (f block id-gen))
- successor*))))
- (info-range (temp-info temp)))
-
- (match mod
- (('module contexts)
- (for-each
- (lambda (cxt)
- (match cxt
- (('context name args start)
- (let ((defs (analyze-defs start)))
- (for-each
- (lambda (def)
- (pretty-print (list def (compute-live-range-for-temp def start))))
- defs)))))
- contexts)))
+ ;; make dummy ranges for unused variables
+ (for-each (lambda (arg)
+ (cond
+ ((null? (mc-vreg-data vreg))
+ (mc-vreg-data-set! vreg (make-range vreg #f (mc-vreg-constraint vreg) -1 -1)))))
+ (mc-cxt-args cxt))
+
+ ;; return all ranges
+ (map (lambda (vreg) (mc-vreg-data vreg)) (mc-cxt-vregs cxt)))
+
+
+;; TODO: abstract over arch specifics
+(define *regs-default* '(rax rbx rcx rdx rsi rdi r8 r9 r10 r11 r12 r13 r14 r15))
+
+(define (regs-reset)
+ (set! *regs* *all-regs*))
+
+(define (regs-free?)
+ (not (null? *regs*)))
+
+(define (reg-free reg)
+ (set! *regs* (cons reg *regs*)))
+
+(define (reg-alloc reserved)
+ (cond
+ ((null? *regs*)
+ (assert-not-reached))
+ (else
+
+
+
+ (let ((reg (find (lambda (reg)
+ (not (find (lambda (ignore)
+ (eq? reg ignore))
+ ignores)))
+ *regs*)))
+ (set! *regs* (lset-difference eq? *regs* (list reg)))
+ reg))))
+
+(define (regs-remove name)
+ (cond
+ ((null? *regs*) (assert-not-reached))
+ ((memq name *regs*)
+ (set! *regs* (lset-difference eq? *regs* (list name)))
+ name)
+ (else (assert-not-reached))))
+
+;; Expire constrained ranges which end before the given range starts
+;;
+;; returns constrained ranges which have not yet expired
+;;
+(define (expire-constrained range constrained)
+ (let f ((c* constrained) (acc '()))
+ (match c*
+ (() (reverse acc))
+ ((c . c*)
+ (cond
+ ((< (range-end c) (range-start range))
+ (f c* acc))
+ (else
+ (f c* (cons c acc))))))))
+
+;; Expire active ranges which end before the given range starts
+;;
+;; returns active ranges that have not yet expired
+;;
+(define (expire range active)
+ (let f ((a* active) (acc '()))
+ (match a*
+ (() acc)
+ ((a . a*)
+ (cond
+ ((< (range-end a) (range-start range))
+ (regs-push (range-hreg a))
+ (f a* acc))
+ (else
+ (f a* (cons a acc))))))))
+
+(define (assign-register bt range active constrained)
+ (let ((hreg (range-constraint range)))
+ ;; check to see if this range is constrained to a particular register
+ (cond
+ ((or (eq? hreg 'rbp) (eq? hreg 'rsp))
+ ;; rbp and rsp do not take part in the linear scan alogorithm, so we freely assign them to constrained ranges.
+ (range-hreg-set! range hreg))
+ ((not hreg)
+ (let* ((not-use (let loop ((cr* constrained) (x '()))
+ (match cr*
+ (() x)
+ ((cr . cr*)
+ (cond
+ ((> (range-start cr) (range-end range))
+ (loop '() x))
+ ((ranges-overlap? range cr)
+ (loop cr* (lset-union eq? (list (range-constraint cr)) x)))
+ (else (loop cr* x)))))))
+ (assigned (regs-pop not-use)))
+ ;; an unconstrained range; pop a free hreg off the stack of available hregs
+ (range-hreg-set! range assigned)))
+ (else
+ (range-hreg-set! range (regs-remove hreg))))))
+
+(define (spill cxt ranges index vreg)
+ (let loop ((user* (mc-vreg-users vreg)) (ranges ranges))
+ (match user*
+ (()
+ (let f ((range* ranges) (x '()))
+ (match range*
+ (() (sort x range-compare-start))
+ ((range . range*)
+ (cond
+ ((mc-vreg-equal? (range-vreg range) vreg)
+ (f range* x))
+ (else
+ (range-hreg-set! range #f)
+ (f range* (cons range x))))))))
+ ((user . user*)
+ (let ((tmp (mc-context-allocate-vreg cxt (gensym 't))))
+ ;; replace vreg use with another tmp. The vreg contents are now passed between/from the stack and the tmp
+ (mc-instr-replace-vreg user vreg tmp)
+ (cond
+ ((mc-instr-is-read? user vreg)
+ (mc-instr-sp-load-set! user (list index tmp))))
+ (cond
+ ((mc-instr-is-written? vreg)
+ (mc-instr-sp-store-set! user (list index tmp))))
+ (let ((tmp-range (make-range tmp #f #f (mc-instr-number user) (mc-instr-number user))))
+ (loop user* (cons tmp-range ranges))))))))
+
+(define (iterate ranges)
+ (call/cc
+ (lambda (backtrack)
+ (let loop ((ranges ranges)
+ (active '())
+ (constrained (sort
+ (fold (lambda (r x)
+ (if (range-constraint r)
+ (cons r x)
+ x))
+ '()
+ ranges) range-compare-start)))
+ (if (null? ranges)
+ ;; return (#t) to indicate allocation success
+ (list #t)
+ (let* ((next (car ranges))
+ (active (expire next active))
+ (constrained (expire-constrained next constrained)))
+ (pretty-print (format-iteration (range-start next) *regs* next active constrained (cdr ranges)))
+ ;; Backtrack if a spill is required
+ ;; return (#f vreg) to indicate allocation failure
+ (cond
+ ((not (regs-available?))
+ (backtrack (list 'spill (range-vreg next)))))
+ ;; Assign a register
+ (assign-register backtrack next active constrained)
+ ;; loop
+ (let ((active-sorted (sort (cons next active) range-compare-end))
+ (constrained-sorted (sort constrained range-compare-start)))
+ (loop (cdr ranges) active-sorted constrained-sorted))))))))
+
+
+
+(define (scan-context-make mcxt ranges)
+ (let ((scxt (make-scan-context mcxt ranges '() *hregs-default)))
+ scxt))
+
+(define (scan cxt ranges)
+
+ (define (update-vregs ranges)
+ (for-each
+ (lambda (range)
+ (mc-vreg-hreg-set! (range-vreg range) (range-hreg range)))
+ ranges))
+
+ ;; enter scanning loop
+ (let loop ((ranges (sort ranges range-compare-start)))
+ (regs-reset)
+ (print (length ranges))
+ (match (iterate ranges)
+ ((#f vreg)
+ ;; Restart the scan after handling the spill
+ (loop (spill cxt ranges (spill-index-gen) vreg)))
+ ((#t)
+ ;; update vregs to reflect the final register assignments
+ (update-vregs ranges)
+
+ (pretty-print
+ `(assignments ,(map (lambda (vreg)
+ `(,(mc-vreg-name vreg) ,(mc-vreg-hreg vreg)))
+ (mc-context-vregs cxt))))))))
+
+(define (allocate-registers-pass cxt)
+ (let* ((ranges (compute-live-ranges cxt (build-graph cxt))))
+ (scan cxt ranges)))
+
+(define (allocate-registers mod)
+ (mc-context-for-each
+ (lambda (cxt)
+ (allocate-registers-pass cxt))
+ mod)
mod)
+
+
View
118 machine.scm
@@ -1,5 +1,5 @@
-(declare (unit mc)
+(declare (unit machine)
(uses nodes))
(use matchable)
@@ -13,37 +13,46 @@
(define-struct mc-block (name head tail succ cxt))
;; instructions
-(define-struct mc-spec (name format verifiers uses defs))
-(define-struct mc-instr (spec ops next prev block data))
+(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))
;; operands
-(define-struct mc-vreg (name users data))
-(define-struct mc-imm (size value))
-(define-struct mc-disp (size value))
+(define-struct mc-vreg (name hreg users data))
+(define-struct mc-imm (size value))
+(define-struct mc-disp (value))
;; Constructors
(define (mc-make-module)
(make-mc-module '()))
-(define (mc-make-context mod name)
- (make-mc-context name '() '() '()))
+(define (mc-make-context name params mod)
+ (arch-make-context name params mod))
(define (mc-make-block cxt name)
(make-mc-block name '() '() '() cxt))
-(define (mc-make-instr blk spec operands)
- (let ((instr (make-mc-instr spec operands '() '() blk '())))
+(define (mc-make-instr blk spec implicit-uses operands)
+ (let ((instr (make-mc-instr spec operands '() '() implicit-uses '() '() #f blk '())))
(for-each (lambda (op)
(cond
((mc-vreg? op)
(mc-vreg-add-user op instr))))
operands)
+ (and blk (mc-block-append blk instr))
instr))
-
+(define mc-make-vreg
+ (lambda operands
+ (match operands
+ ((name)
+ (make-mc-vreg name #f'() '()))
+ ((name hreg-constraint)
+ (make-mc-vreg name #f '() '()))
+ (else (assert-not-reached)))))
+
;; Operand Protocol
@@ -53,23 +62,13 @@
(mc-disp-equal? o1 o2)))
(define (mc-operand-format op)
- (cond
- ((mc-vreg? op)
- (mc-vreg-format op))
- ((mc-imm? op)
- (mc-imm-format op))
- ((mc-disp? op)
- (mc-disp-format op))
- (else (assert-not-reached))))
+ (arch-operand-format op))
;; Vreg Protocol
(define (mc-vreg-equal? v1 v2)
(and (mc-vreg? v1) (mc-vreg? v2) (eq? v1 v2)))
-(define (mc-vreg-format v)
- (arch-format-vreg v))
-
(define (mc-vreg-add-user vreg instr)
(mc-vreg-users-set! vreg (cons instr (mc-vreg-users vreg))))
@@ -77,22 +76,19 @@
(mc-vreg-users-set! vreg
(lset-difference mc-vreg-equal? (mc-vreg-users vreg) (list instr))))
+(define (mc-vreg-param? v)
+ (mc-vreg-attribs v))
+
;; Imm Protocol
(define (mc-imm-equal? i1 i2)
(and (mc-imm? i1) (mc-imm? i2) (eq? i1 i2)))
-(define (mc-imm-format v)
- (arch-imm-format v))
-
;; Disp Protocol
(define (mc-disp-equal? d1 d2)
(and (mc-disp? d1) (mc-disp? d2) (eq? d1 d2)))
-(define (mc-disp-format v)
- (arch-disp-format v))
-
;; Instruction Protocol
;; Get all vregs that are read
@@ -103,10 +99,23 @@
(define (mc-instr-vregs-written instr)
(arch-vregs-written instr))
+(define (mc-instr-is-read? instr vreg)
+ (and (find (lambda (x)
+ (mc-vreg-equal? x vreg))
+ (mc-instr-vregs-read instr))
+ #t))
+
+(define (mc-instr-is-written? instr vreg)
+ (and (find (lambda (x)
+ (mc-vreg-equal? x vreg))
+ (mc-instr-vregs-written instr))
+ #t))
+
;; Replace a vreg
(define (mc-instr-replace-vreg instr vreg x)
(define (replace ops)
- (fold (lambda (op)
+ (reverse
+ (fold (lambda (op ops)
(cond
((mc-operand-equal? op vreg)
(mc-vreg-remove-user op instr)
@@ -115,12 +124,33 @@
(else
(cons op ops))))
'()
- ops))
+ ops)))
(mc-instr-ops-set! instr (replace (mc-instr-ops instr))))
+;; Context Protocol
+
+(define mc-context-allocate-vreg
+ (lambda operands
+ (match operands
+ ((cxt name rest* ...)
+ (let ((vregs (mc-context-vregs cxt)))
+ (cond
+ ((find (lambda (vreg)
+ (eq? (mc-vreg-name vreg) name))
+ vregs)
+ => (lambda (vreg) vreg))
+ (else
+ (let ((vreg (if (null? rest*) (mc-make-vreg name) (mc-make-vreg name (car rest*)))))
+ (mc-context-vregs-set! cxt (cons vreg vregs))
+ vreg)))))
+ (else (assert-not-reached)))))
+
;; Printing
(define (mc-module-print mod port)
+
+ (fprintf port "section .text\n\n")
+ (fprintf port " global __scheme_exec\n\n")
(mc-context-for-each
(lambda (context)
(mc-context-print context port))
@@ -129,6 +159,9 @@
(define (mc-context-print context port)
(struct-case context
((mc-context name args entry)
+
+ (fprintf port " # context: name=~s args=~s\n" name (map (lambda (arg) (mc-vreg-name arg)) args))
+
(mc-block-for-each
(lambda (block)
(mc-block-print block port))
@@ -138,7 +171,7 @@
(struct-case block
((mc-block name head tail succ)
;; print label
- (fprintf port "~a:\n" name)
+ (fprintf port " ~a:\n" name)
;; print code
(mc-instr-for-each
(lambda (instr)
@@ -147,16 +180,21 @@
(fprintf port "\n"))))
(define (mc-instr-print instr port)
- (fprintf port " ")
+ (let* ((fmt (mc-spec-fmt (mc-instr-spec instr)))
+ (fmt-indices (mc-spec-fmt-indices (mc-instr-spec instr)))
+ (ops-vect (list->vector (mc-instr-ops instr)))
+ (ops-sorted (reverse (fold (lambda (i x)
+ (cons (vector-ref ops-vect (- i 1)) x))
+ '()
+ fmt-indices))))
+;; (fprintf port " # live = ~s\n" (map (lambda (vreg) (mc-vreg-name vreg)) (mc-instr-data instr)))
+ (fprintf port " ")
(fprintf port
(apply format
(cons
- (mc-descriptor-format (mc-instr-descriptor instr))
- (map mc-operand-format (mc-instr-ops instr)))))
- (fprintf port "\n"))
-
-
-;; Insertion
+ fmt
+ (map mc-operand-format ops-sorted))))
+ (fprintf port "\n")))
(define (mc-block-append blk instr)
@@ -170,7 +208,7 @@
(mc-instr-prev-set! instr tail)
(mc-instr-next-set! tail instr)
(mc-block-tail-set! blk instr))))
- block)
+ blk)
(define (mc-block-insert-after blk instr x)
(let ((next (mc-instr-next instr))
@@ -211,7 +249,7 @@
(define (mc-block-for-each f context)
(define (visit-block block f)
- (let ((succ (mc-block-successors block)))
+ (let ((succ (mc-block-succ block)))
(f block)
(for-each (lambda (succ)
(visit-block succ f))
View
5 main.scm
@@ -64,8 +64,9 @@
closure-convert
flatten
tree-convert
- select-instructions
- analyze-liveness-pass))
+ select-instructions))
+;; allocate-registers))
+ ;; allocate-registers
(define (compile pipeline source)
(let f ((pass pipeline) (input source))
View
16 munch-syntax.scm
@@ -16,8 +16,8 @@
(%gensym (r 'gensym))
(%block (r 'block))
(%tree (r 'tree))
- (%t1 (gensym))
- (%mc-block-append (r 'mc-block-append ))
+ (%t1 (gensym 't))
+ (%mc-block-append (r 'mc-block-append))
(%mc-context-allocate-vreg (r 'mc-context-allocate-vreg))
(%mc-block-cxt (r 'mc-block-cxt)))
@@ -101,7 +101,7 @@
;; atoms
(('const size x)
- `($ tree-constant ',size ,x))
+ `($ tree-constant ',size ,x))
(('label x)
`($ tree-label ,x))
(('temp x)
@@ -155,7 +155,7 @@
`(,pat-compiled
(,%let* ,bindings
- `(arch-emit-code ,arch ,%block ,@tmpl*)
+ (arch-emit-code ,arch ,%block ,@tmpl*)
,out))))
(define (compile arch rule)
@@ -180,7 +180,13 @@
(let* ((rule-compiled* (compile-rules arch rule*))
(function-name (string->symbol (format "munch-~s" arch))))
-
+;; (pretty-print
+;; `(,%define (,function-name ,%block ,%tree)
+;; (,%match ,%tree
+;; (($ tree-temp ,%t1)
+;; (,%mc-context-allocate-vreg (,%mc-block-cxt ,%block) ,%t1))
+;; ,@rule-compiled*
+;; (_ (tree-instr-print ,%tree (current-output-port)) (error "no matching pattern")))))
`(,%define (,function-name ,%block ,%tree)
(,%match ,%tree
View
4 nodes.scm
@@ -40,12 +40,12 @@
(define-struct module (contexts))
-(define-struct node (id type value pred succ))
(define-struct context (formals start blocks))
(define-struct arch-descriptor
- (operand-format
+ (make-context
+ operand-format
vregs-read
vregs-written
generate-bridge-context
View
53 pass.scm
@@ -717,13 +717,13 @@
(tree-block-add-statement! block
(cond
((tree-constant? v)
- (tree-build-store 'i64 v (tree-build-add 'i32 base (tree-constant-get 'i32 i))))
+ (tree-build-store 'i64 v (tree-build-add 'i32 base (tree-constant-get 'i32 (* 8 i)))))
((tree-temp? v)
(tree-build-store 'i64
- v (tree-build-add 'i32 base (tree-constant-get 'i32 i))))
+ v (tree-build-add 'i32 base (tree-constant-get 'i32 (* 8 i)))))
((tree-label? v)
(tree-build-store 'i64
- (tree-build-load 'ptr64 v) (tree-build-add 'i32 base (tree-constant-get 'i32 i))))
+ (tree-build-load 'ptr64 v) (tree-build-add 'i32 base (tree-constant-get 'i32 (* 8 i)))))
(else (assert-not-reached))))
(f v* (+ i 1))))))
@@ -802,7 +802,7 @@
(struct-case node
((fix defs body)
(let* ((mod (tree-make-module))
- (defs (cons (make-lambda '__scheme_enter '() body '()) defs)))
+ (defs (cons (make-lambda 'begin '() body '()) defs)))
;; convert the definitions into function bodies
(for-each (lambda (def)
@@ -816,39 +816,32 @@
((tree-module functions)
(let* ((mc-mod (mc-make-module))
(cxts (map (lambda (fun)
- (select-instructions-for-function mc-mod fun))
+ (select-function mc-mod fun))
functions)))
+ (arch-generate-bridge-context mc-mod)
mc-mod))
(else (assert-not-reached))))
-(define (select-instructions-for-function mc-mod fun)
+(define (select-function mc-mod fun)
+ (define (walk-block block mcxt mblk)
+ (let ((succ (map (lambda (succ)
+ (walk-block
+ succ
+ mcxt
+ (mc-make-block mcxt (tree-block-name succ))))
+ (tree-block-succ block))))
- (define (walk-block mc-cxt block)
- (let ((mc-blk (mc-make-block mc-cxt (tree-block-name block))))
-
- (mc-block-succ-set! mc-blk
- (map (lambda (succ)
- (walk-block mc-cxt succ))
- (tree-block-succ block)))
-
- ;; if this the special __scheme_enter block, then add a prologue to make it a calleable C function
- (if (eq? (mc-block-name mc-blk) '__scheme_enter)
- (gen-entry-prologue mc-blk))
-
- ;; munch each statement
- (tree-for-each-statement
- (lambda (stm)
- (munch-statement mc-blk stm))
- block)
- mc-blk))
+ (mc-block-succ-set! mblk succ)
+
+ (tree-for-each-statement (lambda (stm)
+ (arch-emit-statement mblk stm))
+ block)
+ mblk))
(struct-case fun
- ((tree-function name args entry module)
- (let* ((args (map (lambda (tmp)
- (tree-temp-name tmp))
- args))
- (mc-cxt (mc-make-context mc-mod name args)))
- (mc-cxt-start-set! mc (walk-block mc-cxt entry))
+ ((tree-function name params entry module)
+ (let* ((mc-cxt (mc-make-context name (map (lambda (p) (tree-temp-name p)) params) mc-mod)))
+ (walk-block entry mc-cxt (mc-context-start mc-cxt))
mc-cxt))
(else (assert-not-reached))))
View
2 tests/simple-002.scm
@@ -1 +1 @@
-(fx+ 3 4)
+(if 3 4 5)
View
2 tree.scm
@@ -202,7 +202,7 @@
(let ((node
(tree-make-instr
(op 'cmp)
- (mode 'i32)
+ (mode 'i64)
(in1 test)
(in2 x)
(in3 y))))

0 comments on commit b3931a9

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