Skip to content

Commit bd04e6b

Browse files
dvanhorndvanhorn
committed
Refactor.
1 parent 3a365b2 commit bd04e6b

1 file changed

Lines changed: 162 additions & 109 deletions

File tree

‎www/notes/hustle/compile.rkt‎

Lines changed: 162 additions & 109 deletions
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,7 @@
2222
;; end in #b000 and we tag with #b001 for boxes, etc.
2323

2424
;; type CEnv = (Listof (Maybe Variable))
25+
;; type Imm = Integer | Boolean | '()
2526

2627
;; Expr -> Asm
2728
(define (compile e)
@@ -39,112 +40,160 @@
3940
;; Expr CEnv -> Asm
4041
(define (compile-e e c)
4142
(match e
42-
[''() `((mov rax ,imm-type-empty))]
43-
[`(box ,e0)
44-
(let ((c0 (compile-e e0 c)))
45-
`(,@c0
46-
(mov (offset rdi 0) rax)
47-
(mov rax rdi)
48-
(or rax ,type-box)
49-
(add rdi 8)))] ; allocate 8 bytes
50-
[`(unbox ,e0)
51-
(let ((c0 (compile-e e0 c)))
52-
`(,@c0
53-
;; assert box
54-
(xor rax ,type-box)
55-
(mov rax (offset rax 0))))]
56-
[`(cons ,e0 ,e1)
57-
(let ((c0 (compile-e e0 c))
58-
(c1 (compile-e e1 (cons #f c))))
59-
`(,@c0
60-
(mov (offset rsp ,(- (add1 (length c)))) rax)
61-
,@c1
62-
(mov (offset rdi 0) rax)
63-
(mov rax (offset rsp ,(- (add1 (length c)))))
64-
(mov (offset rdi 1) rax)
65-
(mov rax rdi)
66-
(or rax ,type-pair)
67-
(add rdi 16)))]
68-
[`(car ,e0)
69-
(let ((c0 (compile-e e0 c)))
70-
`(,@c0
71-
;; assert pair
72-
(xor rax ,type-pair)
73-
(mov rax (offset rax 1))))]
74-
[`(cdr ,e0)
75-
(let ((c0 (compile-e e0 c)))
76-
`(,@c0
77-
;; assert pair
78-
(xor rax ,type-pair)
79-
(mov rax (offset rax 0))))]
80-
[(? integer? i)
81-
`((mov rax ,(arithmetic-shift i imm-shift)))]
82-
[(? boolean? b)
83-
`((mov rax ,(if b imm-type-true imm-type-false)))]
84-
[`(add1 ,e0)
85-
(let ((c0 (compile-e e0 c)))
86-
`(,@c0
87-
,@assert-integer
88-
(add rax ,(arithmetic-shift 1 imm-shift))))]
89-
[`(sub1 ,e0)
90-
(let ((c0 (compile-e e0 c)))
91-
`(,@c0
92-
,@assert-integer
93-
(sub rax ,(arithmetic-shift 1 imm-shift))))]
94-
[`(zero? ,e0)
95-
(let ((c0 (compile-e e0 c))
96-
(l0 (gensym))
97-
(l1 (gensym)))
98-
`(,@c0
99-
,@assert-integer
100-
(cmp rax 0)
101-
(mov rax ,imm-type-false)
102-
(jne ,l0)
103-
(mov rax ,imm-type-true)
104-
,l0))]
105-
[`(if ,e0 ,e1 ,e2)
106-
(let ((c0 (compile-e e0 c))
107-
(c1 (compile-e e1 c))
108-
(c2 (compile-e e2 c))
109-
(l0 (gensym))
110-
(l1 (gensym)))
111-
`(,@c0
112-
(cmp rax ,imm-type-false)
113-
(je ,l0)
114-
,@c1
115-
(jmp ,l1)
116-
,l0
117-
,@c2
118-
,l1))]
119-
[(? symbol? x)
120-
(let ((i (lookup x c)))
121-
`((mov rax (offset rsp ,(- (add1 i))))))]
122-
[`(let ((,x ,e0)) ,e1)
123-
(let ((c0 (compile-e e0 c))
124-
(c1 (compile-e e1 (cons x c))))
125-
`(,@c0
126-
(mov (offset rsp ,(- (add1 (length c)))) rax)
127-
,@c1))]
128-
129-
[`(+ ,e0 ,e1)
130-
(let ((c1 (compile-e e1 c))
131-
(c0 (compile-e e0 (cons #f c))))
132-
`(,@c1
133-
,@assert-integer
134-
(mov (offset rsp ,(- (add1 (length c)))) rax)
135-
,@c0
136-
,@assert-integer
137-
(add rax (offset rsp ,(- (add1 (length c)))))))]
138-
139-
[`(- ,e0 ,e1)
140-
(let ((c1 (compile-e e1 c))
141-
(c0 (compile-e e0 (cons #f c))))
142-
`(,@c1
143-
,@assert-integer
144-
(mov (offset rsp ,(- (add1 (length c)))) rax)
145-
,@c0
146-
,@assert-integer
147-
(sub rax (offset rsp ,(- (add1 (length c)))))))]))
43+
[(? imm? i) (compile-imm i)]
44+
[(? symbol? x) (compile-var x c)]
45+
[`(box ,e0) (compile-box e0 c)]
46+
[`(unbox ,e0) (compile-unbox e0 c)]
47+
[`(cons ,e0 ,e1) (compile-cons e0 e1 c)]
48+
[`(car ,e0) (compile-car e0 c)]
49+
[`(cdr ,e0) (compile-cdr e0 c)]
50+
[`(add1 ,e0) (compile-add1 e0 c)]
51+
[`(sub1 ,e0) (compile-sub1 e0 c)]
52+
[`(zero? ,e0) (compile-zero? e0 c)]
53+
[`(if ,e0 ,e1 ,e2) (compile-if e0 e1 e2 c)]
54+
[`(let ((,x ,e0)) ,e1) (compile-let x e0 e1 c)]
55+
[`(+ ,e0 ,e1) (compile-+ e0 e1 c)]
56+
[`(- ,e0 ,e1) (compile-- e0 e1 c)]))
57+
58+
;; Any -> Boolean
59+
(define (imm? x)
60+
(or (integer? x)
61+
(boolean? x)
62+
(equal? ''() x)))
63+
64+
;; Imm -> Asm
65+
(define (compile-imm i)
66+
`((mov rax
67+
,(match i
68+
[(? integer? i) (arithmetic-shift i imm-shift)]
69+
[(? boolean? b) (if b imm-type-true imm-type-false)]
70+
[''() imm-type-empty]))))
71+
72+
;; Variable CEnv -> Asm
73+
(define (compile-var x c)
74+
(let ((i (lookup x c)))
75+
`((mov rax (offset rsp ,(- (add1 i)))))))
76+
77+
;; Expr CEnv -> Asm
78+
(define (compile-box e0 c)
79+
(let ((c0 (compile-e e0 c)))
80+
`(,@c0
81+
(mov (offset rdi 0) rax)
82+
(mov rax rdi)
83+
(or rax ,type-box)
84+
(add rdi 8)))) ; allocate 8 bytes
85+
86+
;; Expr CEnv -> Asm
87+
(define (compile-unbox e0 c)
88+
(let ((c0 (compile-e e0 c)))
89+
`(,@c0
90+
,@assert-box
91+
(xor rax ,type-box)
92+
(mov rax (offset rax 0)))))
93+
94+
;; Expr Expr CEnv -> Asm
95+
(define (compile-cons e0 e1 c)
96+
(let ((c0 (compile-e e0 c))
97+
(c1 (compile-e e1 (cons #f c))))
98+
`(,@c0
99+
(mov (offset rsp ,(- (add1 (length c)))) rax)
100+
,@c1
101+
(mov (offset rdi 0) rax)
102+
(mov rax (offset rsp ,(- (add1 (length c)))))
103+
(mov (offset rdi 1) rax)
104+
(mov rax rdi)
105+
(or rax ,type-pair)
106+
(add rdi 16))))
107+
108+
;; Expr CEnv -> Asm
109+
(define (compile-car e0 c)
110+
(let ((c0 (compile-e e0 c)))
111+
`(,@c0
112+
,@assert-pair
113+
(xor rax ,type-pair) ; untag
114+
(mov rax (offset rax 1)))))
115+
116+
;; Expr CEnv -> Asm
117+
(define (compile-cdr e0 c)
118+
(let ((c0 (compile-e e0 c)))
119+
`(,@c0
120+
,@assert-pair
121+
(xor rax ,type-pair) ; untag
122+
(mov rax (offset rax 0)))))
123+
124+
;; Expr CEnv -> Asm
125+
(define (compile-add1 e0 c)
126+
(let ((c0 (compile-e e0 c)))
127+
`(,@c0
128+
,@assert-integer
129+
(add rax ,(arithmetic-shift 1 imm-shift)))))
130+
131+
;; Expr CEnv -> Asm
132+
(define (compile-sub1 e0 c)
133+
(let ((c0 (compile-e e0 c)))
134+
`(,@c0
135+
,@assert-integer
136+
(sub rax ,(arithmetic-shift 1 imm-shift)))))
137+
138+
;; Expr CEnv -> Asm
139+
(define (compile-zero? e0 c)
140+
(let ((c0 (compile-e e0 c))
141+
(l0 (gensym))
142+
(l1 (gensym)))
143+
`(,@c0
144+
,@assert-integer
145+
(cmp rax 0)
146+
(mov rax ,imm-type-false)
147+
(jne ,l0)
148+
(mov rax ,imm-type-true)
149+
,l0)))
150+
151+
;; Expr Expr Expr CEnv -> Asm
152+
(define (compile-if e0 e1 e2 c)
153+
(let ((c0 (compile-e e0 c))
154+
(c1 (compile-e e1 c))
155+
(c2 (compile-e e2 c))
156+
(l0 (gensym))
157+
(l1 (gensym)))
158+
`(,@c0
159+
(cmp rax ,imm-type-false)
160+
(je ,l0)
161+
,@c1
162+
(jmp ,l1)
163+
,l0
164+
,@c2
165+
,l1)))
166+
167+
;; Variable Expr Expr CEnv -> Asm
168+
(define (compile-let x e0 e1 c)
169+
(let ((c0 (compile-e e0 c))
170+
(c1 (compile-e e1 (cons x c))))
171+
`(,@c0
172+
(mov (offset rsp ,(- (add1 (length c)))) rax)
173+
,@c1)))
174+
175+
;; Expr Expr CEnv -> Asm
176+
(define (compile-+ e0 e1 c)
177+
(let ((c1 (compile-e e1 c))
178+
(c0 (compile-e e0 (cons #f c))))
179+
`(,@c1
180+
,@assert-integer
181+
(mov (offset rsp ,(- (add1 (length c)))) rax)
182+
,@c0
183+
,@assert-integer
184+
(add rax (offset rsp ,(- (add1 (length c))))))))
185+
186+
187+
;; Expr Expr CEnv -> Asm
188+
(define (compile-- e0 e1 c)
189+
(let ((c1 (compile-e e1 c))
190+
(c0 (compile-e e0 (cons #f c))))
191+
`(,@c1
192+
,@assert-integer
193+
(mov (offset rsp ,(- (add1 (length c)))) rax)
194+
,@c0
195+
,@assert-integer
196+
(sub rax (offset rsp ,(- (add1 (length c))))))))
148197

149198
;; code for "abc"
150199
'((mov (offset rdi 0)
@@ -170,8 +219,12 @@
170219
[#t (length cenv)]
171220
[#f (lookup x cenv)])]))
172221

173-
(define assert-integer
222+
(define (assert-type mask type)
174223
`((mov rbx rax)
175-
(and rbx ,imm-type-mask)
176-
(cmp rbx 0)
224+
(and rbx ,mask)
225+
(cmp rbx ,type)
177226
(jne err)))
227+
228+
(define assert-integer (assert-type imm-type-mask imm-type-int))
229+
(define assert-box (assert-type result-type-mask type-box))
230+
(define assert-pair (assert-type result-type-mask type-pair))

0 commit comments

Comments
 (0)