-
Notifications
You must be signed in to change notification settings - Fork 5
/
lambda.rkt
220 lines (201 loc) · 8.54 KB
/
lambda.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
#lang racket
(require racket/set)
(require "utilities.rkt")
(require "functions.rkt")
(require "interp.rkt")
(provide compile-R4 lambda-passes lambda-typechecker)
(define compile-R4
(class compile-R3
(super-new)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; type-check : env -> S4 -> S4
(define/override (type-check env)
(lambda (e)
(match e
[`(lambda: ,(and bnd `([,xs : ,Ts] ...)) : ,rT ,body)
(define-values (new-body bodyT)
((type-check (append (map cons xs Ts) env)) body))
(define ty `(,@Ts -> ,rT))
(cond
[(equal? rT bodyT)
(values `(has-type (lambda: ,bnd : ,rT ,new-body) ,ty) ty)]
[else
(error "function body's type does not match return type" bodyT rT)])]
[else ((super type-check env) e)])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; uniquify : env -> S0 -> S0
(define/override (uniquify env)
(lambda (e)
(match e
[`(lambda: ([,xs : ,Ts] ...) : ,rT ,body)
(define new-xs (for/list ([x xs]) (gensym (racket-id->c-id x))))
(define new-env (append (map cons xs new-xs) env))
(define (annotate x t) `[,x : ,t])
`(lambda: ,(map annotate new-xs Ts) : ,rT
,((uniquify new-env) body))]
[else ((super uniquify env) e)])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; reveal-functions
(define/override (reveal-functions funs)
(lambda (e)
(define recur (reveal-functions funs))
(match e
[`(lambda: ,params : ,rT ,body)
`(lambda: ,params : ,rT ,(recur body))]
[else ((super reveal-functions funs) e)])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; convert-to-closures : env -> S4 -> S3
;; The returned hash table maps variable x to (has-type x t). -Jeremy
;; free-variable : expr -> (immutable-hash id expr)
(define/public (free-variables e)
(define (recur e) (free-variables e))
(match e
[`(has-type ,x? ,t)
(if (symbol? x?)
(hash x? e)
(recur x?))]
[(or (? integer?) (? boolean?)) (hash)]
[`(function-ref ,f) (hash)]
[`(let ([,x ,e]) ,body)
(hash-union (recur e) (hash-remove (recur body) x))]
[`(if ,cnd ,thn, els)
(hash-union (recur cnd) (recur thn) (recur els))]
[`(lambda: ([,xs : ,Ts] ...) : ,rT ,body)
(define (rm x h) (hash-remove h x))
(foldl rm (recur body) xs)]
[`(app ,es ...)
(apply hash-union (map recur es))]
[`(,op ,es ...)
(apply hash-union (map recur es))]
[else (error 'free-variables "unmatched ~a" e)]))
(define (convert-fun-body fvs-id free-vars body rt)
(let loop ([xs free-vars] [i 1])
(match xs
['() body]
[`((has-type ,x ,t) . ,xs^)
`(has-type
(let ([,x (has-type (vector-ref (has-type ,fvs-id _)
(has-type ,i Integer))
,t)])
,(loop xs^ (add1 i)))
,rt)]
[else (error 'convert-fun-body "unmatched ~a" xs)])))
(define/public (convert-to-closures)
(lambda (e)
(define (recur e) ((convert-to-closures) e))
(match e
[`(has-type (app ,e ,es ...) ,t)
(define-values (new-e e-fs) (recur e))
(define tmp (gensym 'app))
(define-values (new-es es-fss) (map2 recur es))
(match new-e
[`(has-type ,e^ ,t^)
(values
`(has-type
(let ([,tmp ,new-e])
(has-type (app (has-type (vector-ref (has-type ,tmp ,t^)
(has-type 0 Integer)) _)
(has-type ,tmp ,t^) ,@new-es) ,t))
,t)
(append e-fs (apply append es-fss)))]
[else (error 'convert-to-closures
(format "I assume this shouldn't happen ~a" new-e))])]
[`(has-type (lambda: ([,xs : ,Ts] ...) : ,rT ,body) ,t)
(define-values (new-body body-fs) (recur body))
(let* ([fun-name (gensym 'lambda)]
[params (map (lambda (x T) `[,x : ,T]) xs Ts)]
[ty `(,@Ts ... -> ,rT)]
[rm (lambda (x h) (hash-remove h x))]
[fvs-table (hash->list (foldl rm (free-variables new-body) xs))]
[fvs-expr (map cdr fvs-table)]
[fvT (map caddr fvs-expr)]
[fvs-tmp (gensym 'fvs)])
(debug "fvs: " (map car fvs-table))
(values
`(has-type (vector (has-type (function-ref ,fun-name) _) ,@fvs-expr)
(Vector _ ,@fvT))
;; create closure
(cons `(define (,fun-name ,@(cons `[,fvs-tmp : _] params)) : ,rT
,(convert-fun-body fvs-tmp fvs-expr new-body rT))
body-fs)))]
[`(has-type (function-ref ,f) ,t)
(values `(has-type (vector (has-type (function-ref ,f) _)) (Vector _)) '())]
[`(has-type ,e ,t)
(let-values ([(e b*) (recur e)])
(values `(has-type ,e ,t) b*))]
[(or (? symbol?) (? integer?) (? boolean?))
(values e '())]
[`(let ([,x ,e]) ,body)
(define-values (new-e e-fs) (recur e))
(define-values (new-body body-fs) (recur body))
(values `(let ([,x ,new-e]) ,new-body)
(append e-fs body-fs))]
[`(if ,cnd ,thn, els)
(define-values (new-cnd cnd-fs) (recur cnd))
(define-values (new-thn thn-fs) (recur thn))
(define-values (new-els els-fs) (recur els))
(values `(if ,new-cnd ,new-thn ,new-els)
(append cnd-fs thn-fs els-fs))]
[`(define (,f [,xs : ,Ts] ...) : ,rt ,body)
(define-values (new-body body-fs) (recur body))
(define fvs-tmp (gensym 'fvs))
(let ([params (map (lambda (x T) `[,x : ,T]) xs Ts)])
(cons
`(define (,f ,@(cons `[,fvs-tmp : _] params)) : ,rt
,(convert-fun-body fvs-tmp '() new-body rt))
body-fs))]
[`(program (type ,ty) ,ds ... ,body)
(let-values ([(dss) (map recur ds)]
[(body body-fs) (recur body)])
`(program (type ,ty)
,@(append* dss)
,@body-fs
,body))]
;; Keep the below case last -Jeremy
[`(,op ,(app recur new-es es-fss) ...)
(values `(,op ,@new-es) (append* es-fss))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; uncover-call-live-roots
(define/override (root-type? x)
(or (and (list? x) (set-member? x '->))
(super root-type? x)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Passes
(define lambda-typechecker
(let ([compiler (new compile-R4)])
(send compiler type-check '())))
(define lambda-passes
(let ([compiler (new compile-R4)]
[interp (new interp-R4)])
`(
;("type-check" ,(send compiler type-check '())
; ,(send interp interp-scheme '()))
("uniquify" ,(send compiler uniquify '())
,(send interp interp-scheme '()))
("reveal-functions" ,(send compiler reveal-functions '())
,(send interp interp-F '()))
("convert-to-closures" ,(send compiler convert-to-closures)
,(send interp interp-F '()))
("expose allocation"
,(send compiler expose-allocation)
,(send interp interp-F '()))
("flatten" ,(send compiler flatten #f)
,(send interp interp-C '()))
("instruction selection" ,(send compiler select-instructions)
,(send interp interp-x86 '()))
("liveness analysis" ,(send compiler uncover-live (void))
,(send interp interp-x86 '()))
("build interference" ,(send compiler build-interference
(void) (void) (void))
,(send interp interp-x86 '()))
("build move graph" ,(send compiler
build-move-graph (void))
,(send interp interp-x86 '()))
("allocate registers" ,(send compiler allocate-registers)
,(send interp interp-x86 '()))
("lower conditionals" ,(send compiler lower-conditionals)
,(send interp interp-x86 '()))
("patch instructions" ,(send compiler patch-instructions)
,(send interp interp-x86 '()))
("print x86" ,(send compiler print-x86) #f)
)))