smalltalk-tng
view experiments/codegen/codegen.scm @ 268:e50fccd8b2ca
srfi-1 requires an :optional macro
| author | Tony Garnock-Jones <tonyg@kcbbs.gen.nz> |
|---|---|
| date | Mon Jul 27 21:52:23 2009 +0100 (2009-07-27) |
| parents | f13aea5fd174 |
| children | ec1b599cc7c7 |
line source
1 (load "tinyscheme+cvs20090722/init.scm")
3 (define (check-arg pred val caller) #t)
4 (macro (:optional form)
5 `(if (null? ,(cadr form)) ,(caddr form) (car ,(cadr form))))
6 (load "srfi-1.scm")
8 (define (relocation? x)
9 (and (pair? x)
10 (eq? (car x) 'relocation)))
12 (define (relocation-target x)
13 (cadr x))
15 (define (flatten-and-pre-relocate instrs k)
16 (define (walk instrs acc pos relocs k)
17 (if (null? instrs)
18 (k acc pos relocs)
19 (let ((instr (car instrs))
20 (rest (cdr instrs)))
21 (cond
22 ((relocation? instr) (walk rest acc pos (cons (cons instr pos) relocs) k))
23 ((list? instr) (walk instr acc pos relocs
24 (lambda (acc pos relocs)
25 (walk rest acc pos relocs k))))
26 ((number? instr) (walk rest (cons instr acc) (+ pos 1) relocs k))
27 ((string? instr) (walk rest
28 (append (reverse (map char->integer (string->list instr))) acc)
29 (+ pos (string-length instr))
30 relocs
31 k))
32 (else (error "Invalid instruction in stream" instr))))))
33 (walk instrs '() 0 '()
34 (lambda (acc pos relocs)
35 (k (reverse acc) (reverse relocs)))))
37 (define (*ret) #xC3)
39 (define regs '((eax 0)
40 (ecx 1)
41 (edx 2)
42 (ebx 3)
43 (esp 4)
44 (ebp 5)
45 (esi 6)
46 (edi 7)))
48 (define (reg-num reg)
49 (cond
50 ((assq reg regs) => cadr)
51 (else (error "Invalid register" reg))))
53 (define %eax 'eax)
54 (define %ecx 'ecx)
55 (define %edx 'edx)
56 (define %ebx 'ebx)
57 (define %esp 'esp)
58 (define %ebp 'ebp)
59 (define %esi 'esi)
60 (define %edi 'edi)
62 (define (register=? x y)
63 (eq? x y))
65 (define (register? x)
66 (symbol? x))
68 (define (immediate? x)
69 (or (number? x)
70 (position-independent-immediate? x)))
72 (define (position-independent-immediate? x)
73 (and (pair? x)
74 (eq? (car x) 'position-independent)))
76 (define (position-independent x)
77 (list 'position-independent x))
79 (define (position-independent-address x)
80 (cadr x))
82 (define (memory? x)
83 (and (pair? x)
84 (eq? (car x) '@)
85 (pair? (cdr x))))
87 (define (@ base-reg . maybe-offset)
88 (cond
89 ((and (number? base-reg) (null? maybe-offset))
90 (list '@ base-reg))
91 ((and (register? base-reg) (pair? maybe-offset) (number? (car maybe-offset)))
92 (list '@ base-reg (car maybe-offset)))
93 (else
94 (error "Invalid/unsupported memory reference" `(@ ,base-reg ,@maybe-offset)))))
96 (define (memory-base-reg-or-absolute x)
97 (cadr x))
99 (define (absolute-memory? x)
100 (and (memory? x)
101 (number? (memory-base-reg-or-absolute x))))
103 (define (bitfield . args)
104 (define (loop acc args)
105 ;;(write `(bitfield-loop ,acc ,args))(newline)
106 (if (null? args)
107 acc
108 (let* ((width-parameter (car args))
109 (signed? (negative? width-parameter))
110 (width-in-bits (abs width-parameter))
111 (limit (inexact->exact (expt 2 width-in-bits))))
112 (let ((value (cadr args)))
113 (if (if signed?
114 (let ((half-limit (quotient limit 2)))
115 (or (>= value half-limit)
116 (< value (- half-limit))))
117 (or (>= value limit)
118 (< value 0)))
119 (error "Value exceeds bitfield width" (list width-parameter value))
120 (loop (+ (* acc limit) (modulo value limit))
121 (cddr args)))))))
122 ;;(write `(bitfield ,@args))(newline)
123 (loop 0 args))
125 ;; In 32-bit mode, #x66 is the 16-bit-operand override prefix
127 (define (mod-r-m* mod reg rm)
128 (bitfield 2 mod 3 reg 3 rm))
130 (define (onebyte-immediate? n)
131 (and (number? n) (< n 128) (>= n -128)))
133 (define (imm8 i)
134 (modulo i 256))
136 (define (imm32* i)
137 (list (modulo i 256)
138 (modulo (shr i 8) 256)
139 (modulo (shr i 16) 256)
140 (modulo (shr i 24) 256)))
142 (define (imm32 i)
143 (if (position-independent-immediate? i)
144 (let ((address (position-independent-address i)))
145 (list `(relocation ,address) 0 0 0 0))
146 (imm32* i)))
148 (define (imm32-if test-result i)
149 (if test-result (imm32 i) (imm8 i)))
151 ;; Mod values:
152 ;; 00 - no displacement, [reg]
153 ;; 01 - 8bit displacement, [reg + n]
154 ;; 10 - 32bit displacement, [reg + n]
155 ;; 11 - direct, reg
156 (define (mod-r-m reg modrm)
157 (let ((reg (cond
158 ((number? reg) reg)
159 ((register? reg) (reg-num reg))
160 (else (error "mod-r-m needs a number or a register for reg" reg)))))
161 (cond
162 ((register? modrm)
163 (mod-r-m* 3 reg (reg-num modrm)))
164 ((memory? modrm)
165 (let ((base-reg (memory-base-reg-or-absolute modrm))
166 (offset (if (null? (cddr modrm)) 0 (caddr modrm))))
167 (if (absolute-memory? modrm)
168 ;; raw absolute address, always 32 bits
169 (list (mod-r-m* 0 reg 5) (imm32 base-reg))
170 (let ((mod (cond
171 ((zero? offset) 0)
172 ((onebyte-immediate? offset) 1)
173 (else 2)))
174 (offset-bytes (cond
175 ((zero? offset) '())
176 ((onebyte-immediate? offset) (imm8 offset))
177 (else (imm32 offset)))))
178 (if (register=? base-reg %esp)
179 ;; can't directly use base reg, must use scaled indexing
180 (list (mod-r-m* mod reg 4) #x24 offset-bytes)
181 ;; normal
182 (list (mod-r-m* mod reg (reg-num base-reg)) offset-bytes))))))
183 (else (error "mod-r-m needs a register or memory for modrm" modrm)))))
185 (define (arithmetic-opcode opcode)
186 (cond
187 ((assq opcode '((add 0) (or 1) (adc 2) (sbb 3) (and 4) (sub 5) (xor 6) (cmp 7))) => cadr)
188 (else (error "arithmetic-opcode: Invalid opcode" opcode))))
190 (define (*op opcode source target . maybe-8bit)
191 (let ((opcode (arithmetic-opcode opcode))
192 (w-bit (if (null? maybe-8bit) 1 (if (car maybe-8bit) 0 1))))
193 (cond
194 ((immediate? source)
195 (let ((s-bit (if (and (= w-bit 1) (onebyte-immediate? source)) 1 0)))
196 (if (register=? target %eax)
197 (list (bitfield 2 0 3 opcode 2 2 1 w-bit)
198 (imm32-if (= w-bit 1) source))
199 (list (bitfield 2 2 3 0 1 0 1 s-bit 1 w-bit)
200 (mod-r-m opcode target)
201 (imm32-if (and (= w-bit 1) (not (onebyte-immediate? source))) source)))))
202 ((memory? source)
203 (cond
204 ((not (register? target))
205 (error "*op: Cannot have memory source and non-register target"
206 (list opcode source target)))
207 (else
208 (list (bitfield 2 0 3 opcode 2 1 1 w-bit) (mod-r-m target source)))))
209 ((register? source)
210 (cond
211 ((or (memory? target) (register? target))
212 (list (bitfield 2 0 3 opcode 2 0 1 w-bit) (mod-r-m source target)))
213 (else
214 (error "*op: Cannot have register source and non-mem, non-reg target"
215 (list opcode source target)))))
216 (else
217 (error "*op: Invalid source"
218 (list opcode source target))))))
220 (define (*mov source target . maybe-8bit)
221 (let ((w-bit (if (null? maybe-8bit) 1 (if (car maybe-8bit) 0 1))))
222 (cond
223 ((immediate? source)
224 (if (register? target)
225 ;; special alternate encoding
226 (list (bitfield 4 #b1011 1 w-bit 3 (reg-num target))
227 (imm32-if (= w-bit 1) source))
228 (list (bitfield 2 3 3 0 2 3 1 w-bit)
229 (mod-r-m opcode target)
230 (imm32-if (= w-bit 1) source))))
231 ((memory? source)
232 (cond
233 ((and (absolute-memory? source) (register=? target %eax))
234 ;; special alternate encoding
235 (list (bitfield 7 #b1010000 1 w-bit) (imm32 (memory-base-reg-or-absolute source))))
236 ((not (register? target))
237 (error "*mov: Cannot have memory source and non-register target" (list source target)))
238 (else
239 (list (bitfield 2 2 3 1 2 1 1 w-bit) (mod-r-m target source)))))
240 ((register? source)
241 (cond
242 ((and (absolute-memory? target) (register=? source %eax))
243 ;; special alternate encoding
244 (list (bitfield 7 #b1010001 1 w-bit) (imm32 (memory-base-reg-or-absolute target))))
245 ((or (memory? target) (register? target))
246 (list (bitfield 2 2 3 1 2 0 1 w-bit) (mod-r-m source target)))
247 (else
248 (error "*mov: Cannot have register source and non-mem, non-reg target"
249 (list source target)))))
250 (else
251 (error "*mov: Invalid source" (list source target))))))
253 (define (*call loc)
254 (cond
255 ((immediate? loc)
256 (list #xE8 (imm32 loc)))
257 ((or (register? loc) (memory? loc))
258 (list #xFF (mod-r-m 2 loc)))
259 (else
260 (error "*call: Invalid location" loc))))
262 (define (push32 reg)
263 (mod-r-m* 1 2 (reg-num reg)))
265 (define (pop32 reg)
266 (mod-r-m* 1 3 (reg-num reg)))
268 (define (_CAR) (*mov (@ %eax 4) %eax))
269 (define (_CDR) (*mov (@ %eax 8) %eax))
271 (define (*getip reg)
272 (list (*call 0)
273 (pop32 reg)))
275 (define (code->binary codevec)
276 (list->string (map integer->char codevec)))
278 (define (simple-function . instrs)
279 (flatten-and-pre-relocate
280 instrs
281 (lambda (code relocs)
282 (write `((code ,code) (relocs ,relocs))) (newline)
283 (let ((bin (code->binary code)))
284 (disassemble bin)
285 (build-native-function bin relocs)))))
287 (define (round-up-to-nearest n val)
288 (let ((temp (+ val n -1)))
289 (- temp (remainder temp n))))
291 (define (prelude-function locals-frame-size . instrs)
292 (let* ((existing-unaccounted-for-padding 8) ;; eip and ebp, just before stack adjustment
293 (total-required-space (+ existing-unaccounted-for-padding locals-frame-size))
294 (total-adjustment (- (round-up-to-nearest 16 total-required-space)
295 existing-unaccounted-for-padding)))
296 (simple-function (push32 %ebp)
297 (*mov %esp %ebp)
298 (*op 'sub total-adjustment %esp)
299 instrs
300 (*mov %ebp %esp)
301 (pop32 %ebp)
302 (*ret))))
304 (define x (simple-function
305 (*mov (@ %esp 8) %eax)
306 (_CAR)
307 (*ret)))
309 (define real-code (list #x55 #x89 #xe5 #x83 #xec #x08 #x8b #x45 #x0c #xc9 #xc3))
311 (define y (prelude-function 0
312 (*mov (@ %ebp 12) %eax)
313 (_CAR)))
315 (define mk_integer-addr (lookup-native-symbol "mk_integer"))
316 (define get-native-function-addr
317 (prelude-function 8
318 (*mov (@ %ebp 8) %ecx)
319 (*mov (@ %ebp 12) %eax)
320 (_CAR)
321 (_CAR) ;; function pointer is in car slot
322 (*mov %ecx (@ %esp 0))
323 (*mov %eax (@ %esp 4))
324 (*call (position-independent mk_integer-addr))))
326 (define puts-addr (lookup-native-symbol "puts"))
327 (define puts (prelude-function 4
328 (*mov (@ %ebp 12) %eax)
329 (_CAR)
330 (*mov (@ %eax 4) %eax)
331 (*mov %eax (@ %esp 0))
333 ;(*mov puts-addr %eax)
334 ;(*call %eax)
335 (*call (position-independent puts-addr))
337 (*mov (@ %ebp 12) %eax)))
339 (puts "Hello world")
341 (load "evaluator.scm")
343 (define (make-parameter v)
344 (lambda args
345 (if (null? args)
346 v
347 (begin
348 (set! v (car args))
349 v))))
351 (macro (parameterize form)
352 (let ((bindings0 (cadr form))
353 (body (cddr form)))
354 (let ((bindings (map (lambda (entry) (cons (gensym "p") entry)) bindings0))
355 (retval (gensym "prv")))
356 `(let ,(map (lambda (entry)
357 `(,(car entry) (,(cadr entry))))
358 bindings)
359 ,@(map (lambda (entry)
360 `(,(cadr entry) ,(caddr entry)))
361 bindings)
362 (let ((,retval (begin ,@body)))
363 ,@(map (lambda (entry)
364 `(,(cadr entry) ,(car entry)))
365 bindings)
366 ,retval)))))
368 (define-global! 'jit-compile
369 (lambda (exp)
370 (let ((continuation-depth (make-parameter 0)))
371 (define (error key val) (12345678 'magic-error-procedure key val))
372 (define (undefined) (load-literal 17))
373 (define (allocate-env name v)
374 (write `(allocate-env ,name ,v)) (newline)
375 'local)
376 (define (update-env name old-annotation v)
377 (write `(update-env ,name ,old-annotation)) (newline)
378 old-annotation)
379 (define (load-env name annotation v)
380 (write `(load-env ,name ,annotation)) (newline)
381 v)
382 (define (unbound-variable-read name)
383 (write `(load-implicit-global ,name)) (newline)
384 'implicit-global-value)
385 (define (load-literal x)
386 (write `(load-literal ,x)) (newline)
387 x)
388 (define (load-closure formals f)
389 (write `(load-closure ,formals)) (newline)
390 (parameterize ((continuation-depth 0))
391 (write `(IN================)) (newline)
392 (f formals (lambda (v)
393 (write `(return)) (newline)
394 v))
395 (write `(OUT===============)) (newline)
396 'closure-result))
397 (define (do-if v tk fk)
398 (write `(do-if ,v)) (newline)
399 (write `tk) (newline)
400 (tk)
401 (write `fk) (newline)
402 (fk))
403 (define (push-frame count k)
404 (write `(push-frame ,count)) (newline)
405 k)
406 (define (update-frame index v)
407 (write `(update-frame ,index ,v)) (newline)
408 v)
409 (define (do-primitive names vals expressions k)
410 (write `(%assemble ,names ,vals ,expressions))
411 (k 'primitive-result))
412 (define (do-call operator operands k)
413 (write `(do-call ,(if (= (continuation-depth) 0)
414 'tailcall
415 'normalcall) ,operator ,operands))
416 (newline)
417 (k 'do-call-result))
418 (define (push-continuation k)
419 ;;(write `(push-continuation)) (newline)
420 (continuation-depth (+ (continuation-depth) 1))
421 (lambda (v)
422 ;;(write `(pop-continuation ,v)) (newline)
423 (continuation-depth (- (continuation-depth) 1))
424 (k v)))
425 ((make-eval error undefined allocate-env update-env load-env unbound-variable-read
426 load-literal load-closure do-if push-frame update-frame
427 do-primitive do-call push-continuation)
428 exp))))
430 (jit-compile '(lambda (num)
431 (define (f n) (if (zero? n) 1 (* n (f (- n 1)))))
432 (f num)))