Permalink
Browse files

Moved all x86-64 specifics behind an abstract interface

  • Loading branch information...
1 parent 1a71271 commit 2eb59f394c227791b58792c077fa6befe2f6b322 @vgeddes committed Nov 15, 2012
Showing with 1,256 additions and 1,243 deletions.
  1. +11 −11 Makefile
  2. +168 −0 arch-syntax.scm
  3. +33 −0 arch.scm
  4. +146 −0 arch/x86-64/arch-x86-64.scm
  5. +328 −0 arch/x86-64/rules.scm
  6. +274 −0 arch/x86-64/spec.scm
  7. +44 −109 liveness.scm
  8. +0 −106 machine-syntax.scm
  9. +177 −76 machine.scm
  10. +5 −4 main.scm
  11. +31 −63 munch-syntax.scm
  12. +0 −155 munch.scm
  13. +7 −21 nodes.scm
  14. +30 −23 pass.scm
  15. +0 −436 patterns.scm
  16. +2 −1 utils.scm
  17. +0 −238 x86-64.scm
View
@@ -2,25 +2,25 @@
PACKAGE := scc
VERSION := 0.1
-objects := nodes.o pass.o main.o machine.o liveness.o munch.o utils.o tree.o
+objects := nodes.o pass.o main.o machine.o liveness.o utils.o tree.o arch.o
+
+objects_x86_64 = arch/x86-64/arch-x86-64.o
tests_bin = tests/test-fast-match
all: scc tests
-scc: $(objects)
+scc: $(objects) $(objects_x86_64)
csc -o $@ $^
# extra dependencies
-nodes.o: struct-syntax.scm
-main.o: struct-syntax.scm
-pass.o: struct-syntax.scm
-machine.o: x86-64.scm machine-syntax.scm
-tree.o: struct-syntax.scm
-option-parser.o: struct-syntax.
-
-munch.o: patterns.scm munch-syntax.scm nodes.scm
+nodes.o: struct-syntax.scm
+main.o: struct-syntax.scm
+pass.o: struct-syntax.scm
+tree.o: struct-syntax.scm
+arch/x86-64/arch-x86-64.o: arch/x86-64/rules.scm arch/x86-64/spec.scm arch-syntax.scm munch-syntax.scm
+arch.o: nodes.scm
# default rule
@@ -36,7 +36,7 @@ asm-test: asm-test.o asm-test.c
gcc -o asm-test -o $@ $^
asm-test.o: asm-test.nasm
- nasm -f elf64 -g -o $@ $^
+ nasm -f elf64 -g -o $@ $^
dist: tarball
View
@@ -0,0 +1,168 @@
+
+(import-for-syntax matchable)
+(import-for-syntax srfi-1)
+
+
+(define-syntax assert-not-reached
+ (lambda (e r c)
+ `(,(r 'assert) #f "should not reach here")))
+
+(define-syntax define-arch-instructions
+ (lambda (e r c)
+
+;; operand types
+;; i8 8-bit immediate
+;; i32 32-bit immediate
+;; i64 64-bit immediate
+;; m64 64-bit memory reference (using [base + disp] addressing)
+;; r8 8-bit register
+;; r64 64-bit register
+
+ (define (parse-operand-type type)
+ (case type
+ ((i8 i32 i64)
+ 'mc-imm?)
+ ((disp32)
+ 'mc-disp?)
+ ((reg)
+ 'mc-vreg?)
+ (else (assert-not-reached))))
+
+ (define (is-in? flags)
+ (and (memq 'in flags) #t))
+
+ (define (is-out? flags)
+ (and (memq 'out flags) #t))
+
+ ;; Generate a function for accessing specific temps, based on an input list of booleans
+ ;; Used to to created def/use accessors.
+ ;;
+ (define (gen-accessor bool-flag*)
+ (define (accessor index)
+ (case index
+ ((0) 'car)
+ ((1) 'cadr)
+ ((2) 'caddr)
+ ((3) 'cadddr)
+ (else (assert-not-reached))))
+ (let f ((flag* bool-flag*) (i 0) (accessors '()))
+ (match flag*
+ (()
+ `(lambda (ops) (append ,@(reverse accessors))))
+ ((flag . flag*)
+ (let ((accessors (if flag
+ (cons `(mc-operand-vregs (,(accessor i) ops)) accessors)
+ accessors)))
+ (f flag* (+ i 1) accessors))))))
+
+
+ ;; Parse the operand spec string and return the following three lists
+ ;;
+ ;;
+ ;; list of verifier functions for each operand
+ ;; list of booleans indicating temps which are USED
+ ;; list of booleans indicating temps which are DEFINED
+ ;;
+ ;; For example
+ ;; ((i32) (r64 in)) => ((mc-imm? mc-vreg?)
+ ;; (#f #t)
+ ;; (#f #f)
+ ;;
+
+ (define (parse-operand-specs operand-spec*)
+ (let f ((os* operand-spec*) (i 0) (uses '()) (defs '()) (verifiers '()))
+ (match os*
+ (()
+ (list
+ (reverse verifiers)
+ (reverse uses)
+ (reverse defs)))
+ ((os . os*)
+ (match os
+ ((type flag* ...)
+ (let ((verifier (parse-operand-type type))
+ (uses (if (is-in? flag*)
+ (cons #t uses)
+ (cons #f uses)))
+ (defs (if (is-out? flag*)
+ (cons #t defs)
+ (cons #f defs))))
+ (f os* (+ i 1) uses defs (cons verifier verifiers)))))))))
+
+
+ (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)))
+ (operand-info (parse-operand-specs operand-spec*))
+ (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))
+ (%mc-make-instr (r 'mc-make-instr))
+ (%make-mc-spec (r 'make-mc-spec)))
+
+ `((,%define ,spec
+ (,%make-mc-spec
+ ',name
+ ',fmt
+ ',verifiers
+ ,vregs-read
+ ,vregs-written))
+ (,%define ,predicate
+ (,%lambda (x)
+ (and (mc-instr? x) (eq? (mc-instr-spec x) ,spec))))
+ (,%define ,name
+ (,%lambda operands
+ (mc-make-instr ,spec operands))))))
+
+ (match e
+ (('define-arch-instructions arch spec* ...)
+ (let ((code
+ (apply append
+ (map (lambda (instr-def)
+ (match instr-def
+ ((name (operand-spec* ...) fmt)
+ (gen-instr-spec arch name fmt operand-spec*))))
+ spec*)))
+ (%begin (r 'begin)))
+ `(,%begin
+ ,@code))))))
+
+;; Convenience macro for manual code emission
+
+(define-syntax arch-emit-code
+ (lambda (e r c)
+
+ (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)))
+
+ (match e
+ ((e1* ...)
+ (map (lambda (e) (expand blk e)) e1*))
+ (('vreg x)
+ `(,%mc-context-allocate-vreg (,%mc-block-cxt ,blk) ,x))
+ (('imm size x)
+ `(,%mc-make-imm ,size ,x))
+ (('disp x)
+ `(,%mc-make-disp ,x))
+ (_ 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*))))))
+
+ (match e
+ (('arch-emit-code arch blk x* ...)
+ `(begin
+ ,@(map (lambda (instr)
+ (generate arch blk instr))
+ x*))))))
+
+
View
@@ -0,0 +1,33 @@
+(declare (unit arch)
+ (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))
+
+;; Get all vregs that are written to in this instr
+(define (arch-vregs-written instr)
+ ((arch-descriptor-vregs-written) 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))
+
+;; Format an operand
+;;
+(define (arch-operand-format op)
+ ((arch-descriptor-operand-format *arch*) op))
+
+;; Instruction selection
+;;
+(define (arch-emit-statement mc-blk tree)
+ ((arch-descriptor-emit-statement *arch*) mc-blk tree))
+
+
+
View
@@ -0,0 +1,146 @@
+
+(declare (unit arch-x86-64)
+ (uses arch tree nodes))
+
+(use matchable)
+(use srfi-1)
+
+(include "arch-syntax")
+(include "munch-syntax")
+(include "arch/x86-64/spec")
+(include "arch/x86-64/rules")
+
+(define (operand-format-x86-64 op)
+ (cond
+ ((mc-vreg? op)
+ (format "%~s" name))
+ ((mc-imm? op)
+ (format "~s" value))
+ ((mc-disp? op)
+ (format "~s" value))
+ (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)))
+ (cond
+ ((x86-64.xor.rr? instr)
+ (cond
+ ((mc-vreg-equal? (first ops) (second ops))
+ (list))
+ (else reads)))
+ (else reads))))
+
+(define (vregs-written-x86-64 instr)
+ (let ((ops (mc-instr-ops instr))
+ (writes ((mc-spec-written (mc-instr-spec instr)) ops)))
+ writes))
+
+
+;; Generate x86-64 code for the 'return' instruction
+;;
+(define (emit-return-x86-64 block value)
+ ;; move return value into %rax
+ (cond
+ ((tree-constant? value)
+ (case (tree-constant-size value)
+ ((i64)
+ (arch-emit-code x86-64 block
+ (xor64.rr (vreg 'rax) (vreg 'rax)))
+ (mov64.i64r (imm i64 (tree-constant-value value)) (vreg 'rax)))
+ (else (assert-not-reached))))
+ ((tree-temp? value)
+ (arch-emit-code x86-64 block
+ (mov.rr (vreg (tree-temp-name value)) (vreg 'rax)))))
+ ;; stack frame management
+ (arch-emit-code x86-64 block
+ (mov64rr (vreg 'rbp) (vreg 'rsp))
+ (pop64r (vreg '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)
+;;
+;; We move each positional arg to a constrained temp
+;; Each temp will be constrained to a standard argument-passing 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
+;; to the constrained temp. This is mostly useful for immediate -> register moves.
+;;
+;; Example:
+;;
+;; lower (app fib45 (t5 t67 3 t34)) =>
+;;
+;; movq t5, r8
+;; movq t67, r9
+;; movq 3, r10
+;; movq 34, r11
+;;
+;; jmp fib45(%rip) # 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*)
+
+ ;; Select instruction for the branch
+ (munch-x86-64 block (tree-make-br target))))
+
+
+(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)))
+
+ (arch-emit-code x86-64 blk
+ ;; prologue
+ (push.r (vreg 'rbp)))
+ (mov.rr (vreg 'rsp) (vreg 'rbp))
+
+ ;; set heap_ptr
+ (mov.rm heap_ptr (disp 'heap_ptr))))
+
+
+;; Selects x86-64 instructions for a tree node
+;;
+(define (emit-statement-x86-64 block tree)
+ (match tree
+ (($ tree-instr 'return _ value)
+ (emit-return-x86-64 block value))
+ (($ tree-instr 'call _ target args)
+ (case (tree-instr-attr tree 'callconv)
+ ((tail)
+ (emit-tail-call block target args))
+ ((cdecl) '())
+ (else (error 'munch-statement "should not reach here"))))
+ (($ tree-instr 'assign _ (? symbol?) ($ tree-instr 'call) _ _ _ _ attrs) '())
+ (_ (munch-x86-64 block tree))))
+
+(define <arch-x86-64>
+ (make-arch-descriptor
+ operand-format-x86-64
+ vregs-read-x86-64
+ vregs-written-86-64
+ generate-bridge-x86-64
+ emit-statement-x86-64))
+
Oops, something went wrong.

0 comments on commit 2eb59f3

Please sign in to comment.