Skip to content

Commit

Permalink
Added make-vector and vector? primitives.
Browse files Browse the repository at this point in the history
  • Loading branch information
kevinw committed Apr 13, 2013
1 parent 5f1cd13 commit 9509746
Show file tree
Hide file tree
Showing 5 changed files with 83 additions and 15 deletions.
5 changes: 2 additions & 3 deletions Makefile
Expand Up @@ -2,8 +2,8 @@ CC=gcc

SCHEME=mzscheme

CFLAGS=-g -O3
CFLAGS32=-g -O3 -arch i386
CFLAGS=-std=c99 -Wall -g -O3
CFLAGS32=$(CFLAGS) -arch i386

BIN=a64.out
ASSEMBLY=output64.s
Expand All @@ -13,7 +13,6 @@ BIN32=a32.out
ASSEMBLY32=output32.s
ASSEMBLYOBJ32=output32.o


all: $(ASSEMBLY) $(BIN)

all32: $(ASSEMBLY32) $(BIN32)
Expand Down
62 changes: 54 additions & 8 deletions compiler.rkt
Expand Up @@ -27,15 +27,16 @@
(define rsp 'rsp)
(define al 'al)

(struct arch (name size-suffix word-size scratch-register stack-register heap-register gcc-arch) #:transparent)
(struct arch (name size-suffix word-size scratch-register scratch-2-register stack-register heap-register gcc-arch) #:transparent)
(define architectures
(list
(list 'x86 (arch "x86" "l" 4 'eax 'esp 'esi "i386"))
(list 'x86_64 (arch "x86_64" "q" 8 'rax 'rsp 'rdi "x86_64"))))
(list 'x86 (arch "x86" "l" 4 'eax 'ebx 'esp 'esi "i386"))
(list 'x86_64 (arch "x86_64" "q" 8 'rax 'rbx 'rsp 'rdi "x86_64"))))

(define current-arch-param (make-parameter default-arch))
(define word-size-param (make-parameter 8))
(define scratch-register (make-parameter rax))
(define scratch-2-register (make-parameter 'rbx))
(define stack-register-param (make-parameter rsp))
(define heap-register-param (make-parameter 'rdi))

Expand All @@ -45,14 +46,15 @@
[current-size-suffix (arch-size-suffix arch)]
[word-size-param (arch-word-size arch)]
[scratch-register (arch-scratch-register arch)]
[scratch-2-register (arch-scratch-2-register arch)]
[stack-register-param (arch-stack-register arch)]
[heap-register-param (arch-heap-register arch)])
(cb))))

(define (compile-cmd input output arch)
; Returns the GCC command to link together a complete progam.
(define gcc-arch-flag (arch-gcc-arch (second (assoc arch architectures))))
(define CFLAGS (format "-Wall -arch ~a -g -O3" gcc-arch-flag))
(define CFLAGS (format "-std=c99 -Wall -g -O3 -arch ~a" gcc-arch-flag)) ; TODO: parse this from the Makefile? emit the makefile?

(format "gcc ~a driver.c aux.c ~a -o ~a" CFLAGS input output))

Expand All @@ -65,6 +67,7 @@
(define-param-id current-arch current-arch-param)
(define-param-id word-size word-size-param)
(define-param-id scratch scratch-register)
(define-param-id scratch-2 scratch-2-register)
(define-param-id stack-register stack-register-param)
(define-param-id heap-register heap-register-param)

Expand Down Expand Up @@ -93,7 +96,6 @@
(define empty-list #b00101111)

(define heap-mask #b00000111)

(define pair-tag #b00000001)
(define vector-tag #b00000010)
(define string-tag #b00000011)
Expand Down Expand Up @@ -130,7 +132,7 @@ END
(define (primcall? x)
(member (first x)
'(add1 sub1 integer->char char->integer zero? integer? boolean?
+ - * = < car cdr)))
pair? + - * = < car cdr make-vector vector?)))

(define (primcall-op x) (first x))
(define (primcall-operand1 x) (second x))
Expand Down Expand Up @@ -239,12 +241,50 @@ END
(sete al)
(sal boolean-shift scratch)
(or! boolean-tag scratch)]
[(pair?)
(emit-expr (primcall-operand1 x) si env)
(and! heap-mask scratch)
(cmp pair-tag scratch)
(mov 0 scratch)
(sete al)
(sal boolean-shift scratch)
(or! boolean-tag scratch)]
[(vector?)
(emit-expr (primcall-operand1 x) si env)
(and! heap-mask scratch)
(cmp vector-tag scratch)
(mov 0 scratch)
(sete al)
(sal boolean-shift scratch)
(or! boolean-tag scratch)]
[(car)
(emit-expr (primcall-operand1 x) si env)
(mov (offset -1 scratch) scratch)]
[(cdr)
(emit-expr (primcall-operand1 x) si env)
(mov (offset (- word-size 1) scratch) scratch)]))
(mov (offset (- word-size 1) scratch) scratch)]
[(make-vector)
(define vec-length (primcall-operand1 x))
(emit-expr vec-length si env) ; length
(mov scratch (offset 0 heap-register)) ; set the length
(mov scratch scratch-2) ; save the length
; todo: memcpy, duh
(let zerofill ([n vec-length])
(unless (zero? n)
(let ([zero-addr (* 2 word-size n)])
(mov 0 (offset zero-addr heap-register))
(zerofill (sub1 n)))))
(mov heap-register scratch) ; scratch = heap | vector-tag
(or! vector-tag scratch)

; the DWORD "offset" trick
; new offset = (offset + align - 1) & ~(align - 1)

(let ([align (* word-size 2)])
(add (sub1 align) scratch-2) ; align size to next
(and! (- (sub1 align)) scratch-2)) ; object boundary

(add scratch-2 heap-register)]))

(define (let? x) (eq? (first x) 'let))
(define (bindings x) (second x))
Expand Down Expand Up @@ -309,14 +349,20 @@ END
(offset (+ word-size (* word-size n)) ebp))
(if (equal? (arch-name current-arch) "x86")
(begin
; todo make a macro for this ala (preserve (ebx esi) proc)
(push ebp)
(mov esp ebp)
(push 'ebx)
(push esi)
(mov (arg 1) esi) ; first param is heap pointer passed into scheme_entry
(proc)
(pop esi)
(pop 'ebx)
(pop ebp))
(proc)))
(begin
(push 'rbx)
(proc)
(pop 'rbx))))

(define (assemble-sources expr filename)
(let ([stack-index (- word-size)]
Expand Down
15 changes: 13 additions & 2 deletions driver.c
Expand Up @@ -21,7 +21,6 @@
#define empty_list B8(00101111)

#define heap_mask B8(00000111)

#define pair_tag B8(00000001)
#define vector_tag B8(00000010)
#define string_tag B8(00000011)
Expand All @@ -38,9 +37,11 @@

scheme_val scheme_entry();

#define UNPACK_FIXNUM(a) (a >> fixnum_shift)

void print_value(scheme_val val, int* return_code) {
if ((val & fixnum_mask) == fixnum_tag) {
printf("%" PRIiPTR, val >> fixnum_shift);
printf("%" PRIiPTR, UNPACK_FIXNUM(val));
} else if ((val & char_mask) == char_tag) {
unsigned char c = val >> char_shift;
printf("%c", c);
Expand All @@ -57,6 +58,16 @@ void print_value(scheme_val val, int* return_code) {
printf(" . ");
print_value(*tail, return_code);
printf(")");
} else if ((val & heap_mask) == vector_tag) {
printf("#(");
size_t* v = (size_t*)(val & ~heap_mask);
size_t vectorLength = UNPACK_FIXNUM(*v);
for (int i = 0; i < vectorLength; ++i) {
if (i > 0)
printf(" ");
printf("%zu", v[i+1]);
}
printf(")");
} else {
printf("got unknown value %zu: ", val);
printBinary(val);
Expand Down
2 changes: 1 addition & 1 deletion input.rkt
@@ -1 +1 @@
(cdr (cons 10 20))
(make-vector 5)
14 changes: 13 additions & 1 deletion test-cases.rkt
Expand Up @@ -134,7 +134,19 @@
"Car/Cdr"

(check-prog '(car (cons 10 20)) "10")
(check-prog '(cdr (cons 10 20)) "20"))
(check-prog '(cdr (cons 10 20)) "20")
(check-prog '(pair? (cons 1 2)) "#t")
(check-prog '(pair? 1) "#f")
(check-prog '(pair? #\c) "#f"))

(test-case
"Vectors"

(check-prog '(make-vector 1) "#(0)")
(check-prog '(vector? (make-vector 1)) "#t")
(check-prog '(vector? #f) "#f")
(check-prog '(vector? 5) "#f"))

;))

;(require rackunit/text-ui)
Expand Down

0 comments on commit 9509746

Please sign in to comment.