smalltalk-tng
view r1/compile.scm @ 323:454c18798969
merger
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Tue Feb 07 11:34:20 2012 -0500 (3 months ago) |
| parents | |
| children |
line source
1 ;; Compile AST to a set of prototype methods and blocks.
3 (define-record-type compilation-state
4 (make-compilation-state* next-literal rev-literals)
5 compilation-state?
6 (next-literal compilation-state-next-literal)
7 (rev-literals compilation-state-rev-literals))
9 (define (make-compilation-state)
10 (make-compilation-state* 0 '()))
12 (define (push-literal state val)
13 (let ((i (compilation-state-next-literal state)))
14 (values i
15 (make-compilation-state* (+ i 1)
16 (cons val (compilation-state-rev-literals state))))))
18 (define (finish-compilation-state state)
19 (list->vector (reverse (compilation-state-rev-literals state))))
21 (define *all-method-code-prologues* '())
22 (define *invocation-count-decay-half-life* 15) ;; seconds
23 (define *invocation-count-update-interval* 4) ;; seconds
24 (define *recompilation-count-limit* 1000)
26 (define (instruction->code instr is-closure)
27 (let ((prologue (vector 0 (if is-closure *true* *false*))))
28 (let ((locative (make-weak-locative prologue 0)))
29 (push! *all-method-code-prologues* locative))
30 (cons prologue instr)))
32 (define (invocation-count-decay-constant)
33 (exp (/ (log 2)
34 (/ *invocation-count-decay-half-life* *invocation-count-update-interval*))))
36 (define (decay-invocation-counts!)
37 (debug 0 "Decaying invocation counts...")
38 (let ((decay-constant (invocation-count-decay-constant)))
39 (set! *all-method-code-prologues*
40 (filter! (lambda (locative)
41 (let ((prologue (locative->object locative)))
42 (if prologue
43 (vector-set! prologue 0 (/ (vector-ref prologue 0) decay-constant)))
44 prologue))
45 *all-method-code-prologues*))))
47 (define (bump-invocation-count! prologue method)
48 (let ((invocation-count (+ (vector-ref prologue 0) 1)))
49 (vector-set! prologue 0 invocation-count)
50 (if (>= invocation-count *recompilation-count-limit*)
51 (begin
52 (vector-set! prologue 0 0)
53 (recompile-method! method)))))
55 (define compile-ThiNG
56 (let ()
57 (define (do-ref cenv state name)
58 (let* ((name (string->symbol name)))
59 (values (cond ((memq name cenv) `#(local ,name))
60 (else `#(global ,name)))
61 state)))
63 (define (compile-tuple cenv state exprs)
64 (let loop ((exprs exprs)
65 (state state)
66 (acc '()))
67 (if (null? exprs)
68 (values (list->vector (reverse acc)) state)
69 (let*-values (((instr state) (compile cenv state (car exprs))))
70 (loop (cdr exprs)
71 state
72 (cons instr acc))))))
74 (define (do-send cenv state selector exprs)
75 (let-values (((selector) (string->symbol selector))
76 ((instrs state) (compile-tuple cenv state exprs)))
77 (values `#(send ,selector ,instrs)
78 state)))
80 (define (do-block cenv state binders statements)
81 (let* ((block (clone-object *block*))
82 (num-formals (length binders))
83 (formals (map string->symbol binders))
84 (formal-cenv (append (cons '_ formals) cenv))
85 (selector (if (zero? num-formals)
86 'do
87 (string->symbol
88 (string-concatenate (cons "applyWith:"
89 (make-list (- num-formals 1) "with:")))))))
90 (let*-values (((instr block-state)
91 (compile formal-cenv (make-compilation-state)
92 `(scope ,*nil* ,statements)))
93 ((litvec) (finish-compilation-state block-state))
94 ((method) (define-method! selector (cons '_ formals) (list block)
95 (instruction->code instr #t)))
96 ((block-index state) (push-literal state block)))
97 (set-slot! method 'literals litvec)
98 (values `#(closure ,block-index)
99 state))))
101 (define (do-scope cenv state name statements)
102 (if (eq? *nil* name)
103 (let-values (((instrs state) (compile-statements cenv state statements)))
104 (values `#(begin ,instrs)
105 state))
106 (let*-values (((name) (string->symbol name))
107 ((instrs state) (compile-statements (cons name cenv) state statements)))
108 (values `#(scope ,name ,instrs)
109 state))))
111 (define (do-literal cenv state val)
112 (let-values (((index state) (push-literal state val)))
113 (values `#(literal ,index)
114 state)))
116 (define (do-update cenv state template-expr updates)
117 (let*-values (((template-instr state) (compile cenv state template-expr))
118 ((updates state)
119 (let loop ((updates updates)
120 (state state)
121 (acc '()))
122 (if (null? updates)
123 (values (list->vector (reverse acc)) state)
124 (let*-values (((update) (car updates))
125 ((update-instr state)
126 (compile cenv state (caddr update))))
127 (loop (cdr updates)
128 state
129 (cons (vector (car update)
130 (string->symbol (cadr update))
131 update-instr)
132 acc)))))))
133 (values `#(update ,template-instr ,updates)
134 state)))
136 (define (do-tuple cenv state exprs)
137 (let-values (((instrs state) (compile-tuple cenv state exprs)))
138 (values `#(tuple ,instrs)
139 state)))
141 (define (do-resend cenv state)
142 (values `#(resend)
143 state))
145 (define (do-method cenv state pattern statements)
146 (let* ((selector (string->symbol (cadr pattern)))
147 (params (caddr pattern))
148 (formals (map (lambda (entry) (string->symbol (or (non-*false*? (car entry))
149 "_")))
150 params)))
151 (let*-values (((specializer-instrs state)
152 (compile-tuple cenv state (map (lambda (entry)
153 (let ((exp (cadr entry)))
154 (if (non-*false*? exp)
155 exp
156 `(ref "NoRole"))))
157 params)))
158 ((body-instr method-state)
159 (compile formals (make-compilation-state) `(scope ,*nil* ,statements)))
160 ((method-litvec) (finish-compilation-state method-state)))
161 (values `#(method ,selector ,formals ,specializer-instrs
162 ,(instruction->code body-instr #f)
163 ,method-litvec)
164 state))))
166 (define (compile-statement cenv state statement)
167 (if (and (pair? statement)
168 (eq? (car statement) 'let))
169 (let* ((name (string->symbol (cadr statement)))
170 (expr (caddr statement))
171 (newenv (cons name cenv)))
172 (let-values (((instr state) (compile newenv state expr)))
173 (values `#(bind ,name ,instr)
174 newenv
175 state)))
176 (let-values (((instr state) (compile cenv state statement)))
177 (values instr cenv state))))
179 (define (compile-statements cenv state statements)
180 (let loop ((cenv cenv)
181 (state state)
182 (statements statements)
183 (acc '()))
184 (if (null? statements)
185 (values (list->vector (reverse acc))
186 state)
187 (let-values (((instr cenv state) (compile-statement cenv state (car statements))))
188 (loop cenv
189 state
190 (cdr statements)
191 (cons instr acc))))))
193 (define (compile cenv state ast)
194 (debug 1 "compile "ast" "cenv)
195 (cond
196 ((pair? ast)
197 (apply (cond
198 ((assq (car ast) `((ref ,do-ref)
199 (send ,do-send)
200 (block ,do-block)
201 (scope ,do-scope)
202 (string ,do-literal)
203 (symbol ,do-literal)
204 (number ,do-literal)
205 (update ,do-update)
206 (tuple ,do-tuple)
207 (resend ,do-resend)
208 (method ,do-method)
209 )) => cadr)
210 (else (error "Unknown ast kind" ast)))
211 cenv state
212 (cdr ast)))
213 (else (error "Non-pair ast" ast))))
215 (lambda (ast)
216 (let-values (((instr state) (compile '() (make-compilation-state) ast)))
217 (values instr
218 (finish-compilation-state state))))))
220 (define (instruction-vector-size seed instr-vec)
221 (vector-fold (lambda (instr acc) (+ (instruction-size instr) acc)) seed instr-vec))
223 (define (instruction-size instr)
224 (case (vector-ref instr 0)
225 ((local global closure literal resend) 1)
226 ((send) (instruction-vector-size 1 (vector-ref instr 2)))
227 ((begin) (instruction-vector-size 0 (vector-ref instr 1)))
228 ((scope) (instruction-vector-size 0 (vector-ref instr 2)))
229 ((update) (instruction-vector-size 1 (vector-ref instr 2)))
230 ((tuple) (instruction-vector-size 1 (vector-ref instr 1)))
231 ((method) 1) ;; not quite correct, but mneh. until the macro is expanded properly, will do.
232 (else (error "Illegal instruction in instruction-size" instr))))
234 (define (recompile-method! method)
235 (let ((instr (cdr (get-slot method 'code))))
236 (pretty-print `(recompile-method!
237 (size ,(instruction-size instr))
238 (instr ,instr)))))