smalltalk-tng
view experiments/codegen/codegen.scm @ 323:454c18798969
merger
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Tue Feb 07 11:34:20 2012 -0500 (3 months ago) |
| parents | e50fccd8b2ca |
| children |
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 (symbol-append . syms)
9 (if (null? syms)
10 (error "No symbols supplied to symbol-append")
11 (string->symbol
12 (fold-right (lambda (sym acc)
13 (if (zero? (string-length acc))
14 (symbol->string sym)
15 (string-append (symbol->string sym) acc)))
16 ""
17 syms))))
19 (macro (cheap-struct form)
20 (let ((record-name (cadr form))
21 (field-names (caddr form)))
22 (let ((maker-name (symbol-append 'make- record-name))
23 (predicate-name (symbol-append record-name '?)))
24 `(begin
25 (define (,maker-name ,@field-names)
26 (vector ',record-name ,@field-names))
27 (define (,predicate-name x)
28 (and (vector? x)
29 (eq? (vector-ref x 0) ',record-name)))
30 ,@(let loop ((field-names field-names)
31 (counter 1))
32 (if (null? field-names)
33 '()
34 (cons `(define (,(symbol-append record-name '- (car field-names)) x)
35 (vector-ref x ,counter))
36 (loop (cdr field-names) (+ counter 1)))))))))
38 (define (filter-map-alist predicate transformer l)
39 (filter-map (lambda (entry) (and (predicate (car entry))
40 (if transformer
41 (transformer (car entry) (cdr entry))
42 entry))) l))
44 (cheap-struct relocation (target))
45 (cheap-struct label-reference (name is-8bit))
46 (cheap-struct label-anchor (name))
48 (define (flatten-and-pre-relocate instrs k)
49 (define (walk instrs acc pos marks k)
50 (if (null? instrs)
51 (k acc pos marks)
52 (let ((instr (car instrs))
53 (rest (cdr instrs)))
54 (cond
55 ((or (relocation? instr)
56 (label-anchor? instr)
57 (label-reference? instr))
58 (walk rest acc pos (cons (cons instr pos) marks) k))
59 ((list? instr) (walk instr acc pos marks
60 (lambda (acc pos marks)
61 (walk rest acc pos marks k))))
62 ((number? instr) (walk rest (cons instr acc) (+ pos 1) marks k))
63 ((string? instr) (walk rest
64 (append (reverse (map char->integer (string->list instr))) acc)
65 (+ pos (string-length instr))
66 marks
67 k))
68 (else (error "Invalid instruction in stream" instr))))))
69 (walk instrs '() 0 '()
70 (lambda (reversed-code final-length reversed-marks)
71 (let* ((code (list->vector (reverse reversed-code)))
72 (marks (reverse reversed-marks))
73 (relocations (filter-map-alist relocation?
74 (lambda (r p) (cons (relocation-target r) p))
75 marks))
76 (anchors (filter-map-alist label-anchor?
77 (lambda (a p) (cons (label-anchor-name a) p))
78 marks))
79 (refs (filter-map-alist label-reference? #f marks)))
80 (define (anchor-pos name)
81 (cond
82 ((assq name anchors) => cdr)
83 (else (error "Undefined label-anchor" name))))
84 (write `(code ,code))(newline)
85 (write `(marks ,marks))(newline)
86 (for-each (lambda (entry)
87 (let ((name (label-reference-name (car entry)))
88 (is-8bit (label-reference-is-8bit (car entry)))
89 (pos (cdr entry)))
90 (if is-8bit
91 (let ((delta (- (anchor-pos name) (+ pos 1))))
92 (if (onebyte-immediate? delta)
93 (vector-set! code pos delta)
94 (error "Short jump out of range" entry)))
95 (let ((v (list->vector (imm32* (- (anchor-pos name) (+ pos 4))))))
96 (vector-set! code (+ pos 0) (vector-ref v 0))
97 (vector-set! code (+ pos 1) (vector-ref v 1))
98 (vector-set! code (+ pos 2) (vector-ref v 2))
99 (vector-set! code (+ pos 3) (vector-ref v 3))))))
100 refs)
101 (k code
102 relocations)))))
104 (define (*ret) #xC3)
106 (define regs '((eax 0)
107 (ecx 1)
108 (edx 2)
109 (ebx 3)
110 (esp 4)
111 (ebp 5)
112 (esi 6)
113 (edi 7)))
115 (define (reg-num reg)
116 (cond
117 ((assq reg regs) => cadr)
118 (else (error "Invalid register" reg))))
120 (define %eax 'eax)
121 (define %ecx 'ecx)
122 (define %edx 'edx)
123 (define %ebx 'ebx)
124 (define %esp 'esp)
125 (define %ebp 'ebp)
126 (define %esi 'esi)
127 (define %edi 'edi)
129 (define condition-codes '#((o)
130 (no)
131 (b nae)
132 (nb ae)
133 (e z)
134 (ne nz)
135 (be na)
136 (nbe a)
137 (s)
138 (ns)
139 (p pe)
140 (np po)
141 (l nge)
142 (nl ge)
143 (le ng)
144 (nle g)))
146 (define (condition-code-num code-sym)
147 (let loop ((i 0))
148 (cond
149 ((>= i 16) (error "Invalid condition-code" code-sym))
150 ((member code-sym (vector-ref condition-codes i)) i)
151 (else (loop (+ i 1))))))
153 (define specials '((undefined 0)
154 (true 1)
155 (false 2)
156 (nil 3)))
158 (define (special-oop special-name)
159 (cond
160 ((assq special-name specials) =>
161 (lambda (entry)
162 (let ((special-num (cadr entry)))
163 (+ 3 (* special-num 8)))))
164 (else (error "Invalid special name" special-name))))
166 (define (register=? x y)
167 (eq? x y))
169 (define (register? x)
170 (symbol? x))
172 (define (immediate? x)
173 (or (number? x)
174 (relocation? x)
175 (label-reference? x)))
177 (define (memory? x)
178 (and (pair? x)
179 (eq? (car x) '@)
180 (pair? (cdr x))))
182 (define (@ base-reg . maybe-offset)
183 (cond
184 ((and (number? base-reg) (null? maybe-offset))
185 (list '@ base-reg))
186 ((and (register? base-reg) (pair? maybe-offset) (number? (car maybe-offset)))
187 (list '@ base-reg (car maybe-offset)))
188 (else
189 (error "Invalid/unsupported memory reference" `(@ ,base-reg ,@maybe-offset)))))
191 (define (memory-base-reg-or-absolute x)
192 (cadr x))
194 (define (absolute-memory? x)
195 (and (memory? x)
196 (number? (memory-base-reg-or-absolute x))))
198 (define (bitfield . args)
199 (define (loop acc args)
200 ;;(write `(bitfield-loop ,acc ,args))(newline)
201 (if (null? args)
202 acc
203 (let* ((width-parameter (car args))
204 (signed? (negative? width-parameter))
205 (width-in-bits (abs width-parameter))
206 (limit (inexact->exact (expt 2 width-in-bits))))
207 (let ((value (cadr args)))
208 (if (if signed?
209 (let ((half-limit (quotient limit 2)))
210 (or (>= value half-limit)
211 (< value (- half-limit))))
212 (or (>= value limit)
213 (< value 0)))
214 (error "Value exceeds bitfield width" (list width-parameter value))
215 (loop (+ (* acc limit) (modulo value limit))
216 (cddr args)))))))
217 ;;(write `(bitfield ,@args))(newline)
218 (loop 0 args))
220 ;; In 32-bit mode, #x66 is the 16-bit-operand override prefix
222 (define (mod-r-m* mod reg rm)
223 (bitfield 2 mod 3 reg 3 rm))
225 (define (onebyte-immediate? n)
226 (and (number? n) (< n 128) (>= n -128)))
228 (define (imm8 i)
229 (modulo i 256))
231 (define (imm32* i)
232 (list (modulo i 256)
233 (modulo (shr i 8) 256)
234 (modulo (shr i 16) 256)
235 (modulo (shr i 24) 256)))
237 (define (imm32 i)
238 (if (or (relocation? i) (label-reference? i))
239 (list i 0 0 0 0)
240 (imm32* i)))
242 (define (imm32-if test-result i)
243 (if test-result (imm32 i) (imm8 i)))
245 ;; Mod values:
246 ;; 00 - no displacement, [reg]
247 ;; 01 - 8bit displacement, [reg + n]
248 ;; 10 - 32bit displacement, [reg + n]
249 ;; 11 - direct, reg
250 (define (mod-r-m reg modrm)
251 (let ((reg (cond
252 ((number? reg) reg)
253 ((register? reg) (reg-num reg))
254 (else (error "mod-r-m needs a number or a register for reg" reg)))))
255 (cond
256 ((register? modrm)
257 (mod-r-m* 3 reg (reg-num modrm)))
258 ((memory? modrm)
259 (let ((base-reg (memory-base-reg-or-absolute modrm))
260 (offset (if (null? (cddr modrm)) 0 (caddr modrm))))
261 (if (absolute-memory? modrm)
262 ;; raw absolute address, always 32 bits
263 (list (mod-r-m* 0 reg 5) (imm32 base-reg))
264 (let ((mod (cond
265 ((zero? offset) 0)
266 ((onebyte-immediate? offset) 1)
267 (else 2)))
268 (offset-bytes (cond
269 ((zero? offset) '())
270 ((onebyte-immediate? offset) (imm8 offset))
271 (else (imm32 offset)))))
272 (if (register=? base-reg %esp)
273 ;; can't directly use base reg, must use scaled indexing
274 (list (mod-r-m* mod reg 4) #x24 offset-bytes)
275 ;; normal
276 (list (mod-r-m* mod reg (reg-num base-reg)) offset-bytes))))))
277 (else (error "mod-r-m needs a register or memory for modrm" modrm)))))
279 (define (arithmetic-opcode opcode)
280 (cond
281 ((assq opcode '((add 0) (or 1) (adc 2) (sbb 3) (and 4) (sub 5) (xor 6) (cmp 7))) => cadr)
282 (else (error "arithmetic-opcode: Invalid opcode" opcode))))
284 (define (*op opcode source target . maybe-8bit)
285 (let ((opcode (arithmetic-opcode opcode))
286 (w-bit (if (null? maybe-8bit) 1 (if (car maybe-8bit) 0 1))))
287 (cond
288 ((immediate? source)
289 (let ((s-bit (if (and (= w-bit 1) (onebyte-immediate? source)) 1 0)))
290 (if (register=? target %eax)
291 (list (bitfield 2 0 3 opcode 2 2 1 w-bit)
292 (imm32-if (= w-bit 1) source))
293 (list (bitfield 2 2 3 0 1 0 1 s-bit 1 w-bit)
294 (mod-r-m opcode target)
295 (imm32-if (and (= w-bit 1) (not (onebyte-immediate? source))) source)))))
296 ((memory? source)
297 (cond
298 ((not (register? target))
299 (error "*op: Cannot have memory source and non-register target"
300 (list opcode source target)))
301 (else
302 (list (bitfield 2 0 3 opcode 2 1 1 w-bit) (mod-r-m target source)))))
303 ((register? source)
304 (cond
305 ((or (memory? target) (register? target))
306 (list (bitfield 2 0 3 opcode 2 0 1 w-bit) (mod-r-m source target)))
307 (else
308 (error "*op: Cannot have register source and non-mem, non-reg target"
309 (list opcode source target)))))
310 (else
311 (error "*op: Invalid source"
312 (list opcode source target))))))
314 (define (*mov source target . maybe-8bit)
315 (let ((w-bit (if (null? maybe-8bit) 1 (if (car maybe-8bit) 0 1))))
316 (cond
317 ((immediate? source)
318 (if (register? target)
319 ;; special alternate encoding
320 (list (bitfield 4 #b1011 1 w-bit 3 (reg-num target))
321 (imm32-if (= w-bit 1) source))
322 (list (bitfield 2 3 3 0 2 3 1 w-bit)
323 (mod-r-m 0 target)
324 (imm32-if (= w-bit 1) source))))
325 ((memory? source)
326 (cond
327 ((and (absolute-memory? source) (register=? target %eax))
328 ;; special alternate encoding
329 (list (bitfield 7 #b1010000 1 w-bit) (imm32 (memory-base-reg-or-absolute source))))
330 ((not (register? target))
331 (error "*mov: Cannot have memory source and non-register target" (list source target)))
332 (else
333 (list (bitfield 2 2 3 1 2 1 1 w-bit) (mod-r-m target source)))))
334 ((register? source)
335 (cond
336 ((and (absolute-memory? target) (register=? source %eax))
337 ;; special alternate encoding
338 (list (bitfield 7 #b1010001 1 w-bit) (imm32 (memory-base-reg-or-absolute target))))
339 ((or (memory? target) (register? target))
340 (list (bitfield 2 2 3 1 2 0 1 w-bit) (mod-r-m source target)))
341 (else
342 (error "*mov: Cannot have register source and non-mem, non-reg target"
343 (list source target)))))
344 (else
345 (error "*mov: Invalid source" (list source target))))))
347 (define (*call-or-jmp-like immediate-opcode indirect-mod loc)
348 (cond
349 ((immediate? loc)
350 (list immediate-opcode (imm32 loc)))
351 ((or (register? loc) (memory? loc))
352 (list #xFF (mod-r-m indirect-mod loc)))
353 (else
354 (error "*call/*jmp: Invalid location" loc))))
356 (define (*call loc)
357 (*call-or-jmp-like #xE8 2 loc))
359 (define (is-short-jump? loc)
360 (and (label-reference? loc)
361 (label-reference-is-8bit loc)))
363 (define (*jmp loc)
364 (if (is-short-jump? loc)
365 (list #xEB loc 0)
366 (*call-or-jmp-like #xE9 4 loc)))
368 (define (*jmp-cc code loc)
369 (write `(*jmp-cc ,code ,loc))(newline)
370 (let ((tttn (condition-code-num code)))
371 (if (is-short-jump? loc)
372 (list (bitfield 4 7 4 tttn) loc 0)
373 (list #x0F (bitfield 4 8 4 tttn) (imm32 loc)))))
375 (define (push32 reg)
376 (mod-r-m* 1 2 (reg-num reg)))
378 (define (pop32 reg)
379 (mod-r-m* 1 3 (reg-num reg)))
381 (define (_CAR) (*mov (@ %eax 4) %eax))
382 (define (_CDR) (*mov (@ %eax 8) %eax))
384 (define (*getip reg)
385 (list (*call 0)
386 (pop32 reg)))
388 (define (code->binary codevec)
389 (list->string (map integer->char (vector->list codevec))))
391 (define (simple-function . instrs)
392 (flatten-and-pre-relocate
393 instrs
394 (lambda (code relocs)
395 (write `((code ,code) (relocs ,relocs))) (newline)
396 (let ((bin (code->binary code)))
397 (disassemble bin)
398 (build-native-function bin relocs)))))
400 (define (round-up-to-nearest n val)
401 (let ((temp (+ val n -1)))
402 (- temp (remainder temp n))))
404 (define (prelude-function locals-frame-size . instrs)
405 (let* ((existing-unaccounted-for-padding 8) ;; eip and ebp, just before stack adjustment
406 (total-required-space (+ existing-unaccounted-for-padding locals-frame-size))
407 (total-adjustment (- (round-up-to-nearest 16 total-required-space)
408 existing-unaccounted-for-padding)))
409 (simple-function (push32 %ebp)
410 (*mov %esp %ebp)
411 (*op 'sub total-adjustment %esp)
412 instrs
413 (*mov %ebp %esp)
414 (pop32 %ebp)
415 (*ret))))
417 (define x (simple-function
418 (*mov (@ %esp 8) %eax)
419 (_CAR)
420 (*ret)))
422 (define real-code (list #x55 #x89 #xe5 #x83 #xec #x08 #x8b #x45 #x0c #xc9 #xc3))
424 (define y (prelude-function 0
425 (*mov (@ %ebp 12) %eax)
426 (_CAR)))
428 (define mk_integer-addr (lookup-native-symbol "mk_integer"))
429 (define get-native-function-addr
430 (prelude-function 8
431 (*mov (@ %ebp 8) %ecx)
432 (*mov (@ %ebp 12) %eax)
433 (_CAR)
434 (_CAR) ;; function pointer is in car slot
435 (*mov %ecx (@ %esp 0))
436 (*mov %eax (@ %esp 4))
437 (*call (make-relocation mk_integer-addr))))
439 (define puts-addr (lookup-native-symbol "puts"))
440 (define puts (prelude-function 4
441 (*mov (@ %ebp 12) %eax)
442 (_CAR)
443 (*mov (@ %eax 4) %eax)
444 (*mov %eax (@ %esp 0))
446 ;(*mov puts-addr %eax)
447 ;(*call %eax)
448 (*call (make-relocation puts-addr))
450 (*mov (@ %ebp 12) %eax)))
452 (puts "Hello world")
454 (load "evaluator.scm")
456 (define (make-parameter v)
457 (lambda args
458 (if (null? args)
459 v
460 (begin
461 (set! v (car args))
462 v))))
464 (macro (parameterize form)
465 (let ((bindings0 (cadr form))
466 (body (cddr form)))
467 (let ((bindings (map (lambda (entry) (cons (gensym "p") entry)) bindings0))
468 (retval (gensym "prv")))
469 `(let ,(map (lambda (entry)
470 `(,(car entry) (,(cadr entry))))
471 bindings)
472 ,@(map (lambda (entry)
473 `(,(cadr entry) ,(caddr entry)))
474 bindings)
475 (let ((,retval (begin ,@body)))
476 ,@(map (lambda (entry)
477 `(,(cadr entry) ,(car entry)))
478 bindings)
479 ,retval)))))
481 (define-global! 'jit-compile
482 (lambda (exp)
483 (let ((env-accumulator #f)
485 (continuation-depth (make-parameter 0))
486 (instruction-rev-acc (make-parameter '()))
487 (frame-depth (make-parameter 0))
488 (frame-stack (make-parameter '())))
490 (define (dp term)
491 (display (make-string (* 2 (length (frame-stack))) #\ ))
492 (write term)
493 (newline))
495 ;; -- Data types used to represent partial values
497 (cheap-struct argument (number))
498 (cheap-struct literal (number))
499 (cheap-struct recursive-binding (number frame-depth))
501 ;; -- Interface to assembler
503 (define (emit! . instrs)
504 (dp `(emit! ,@instrs))
505 (instruction-rev-acc (cons instrs (instruction-rev-acc))))
507 (define (*mov-to-eax source)
508 (if (and (register? source)
509 (register=? source %eax))
510 '()
511 (*mov source %eax)))
513 (define (location-for-value v)
514 (cond
515 ((argument? v) (@ %esp (+ (frame-depth) (* (+ (argument-number v) 1) 4))))
516 ((literal? v) (literal-number v))
517 ((recursive-binding? v) (@ %esp (+ (- (frame-depth) (recursive-binding-frame-depth v))
518 (* (+ (recursive-binding-number v) 1) -4))))
519 ((or (register? v) (memory? v) (immediate? v)) v)
520 (else (error "Invalid PE value" v))))
522 (define (move-esp-by! slot-count)
523 (when (not (zero? slot-count))
524 (let ((nbytes (abs (* slot-count 4))))
525 (emit! (*op (if (positive? slot-count) 'add 'sub) nbytes %esp))
526 (frame-depth ((if (positive? slot-count) - +) (frame-depth) nbytes)))))
528 (define (allocate! nwords)
529 (let ((ok-label (gensym "allocok")))
530 (emit! (*mov %esi %eax)
531 (*op 'add (* nwords 4) %esi)
532 (*op 'cmp %esi %edi)
533 (*jmp-cc 'ge (make-label-reference ok-label #t))
534 (*mov %eax %esi)
535 (*mov (* nwords 4) %eax))
536 (trap! 0)
537 (emit! (make-label-anchor ok-label))))
539 (define (push-frame* count)
540 (dp `(push-frame* ,count (frame-stack ,(frame-stack))))
541 (when (positive? count)
542 (move-esp-by! (- count)))
543 (frame-stack (cons count (frame-stack))))
545 (define (pop-frame*)
546 (dp `(pop-frame* (frame-stack ,(frame-stack))))
547 (let ((count (car (frame-stack))))
548 (when (positive? count)
549 (move-esp-by! (car (frame-stack))))
550 (frame-stack (cdr (frame-stack)))))
552 ;; -- Interpreter-core API
554 ;;(define (error key val)
555 ;;...?)
557 (define (undefined)
558 (special-oop 'undefined))
560 (define (begin-env is-recursive env)
561 (dp `(begin-env ,is-recursive))
562 (set! env-accumulator (if is-recursive 0 #f))
563 env)
565 (define (allocate-env name v)
566 (dp `(allocate-env ,name ,v))
567 (if env-accumulator
568 (let ((a (make-recursive-binding env-accumulator (frame-depth))))
569 (set! env-accumulator (+ env-accumulator 1))
570 a)
571 (or v (undefined))))
573 (define (end-env is-recursive env)
574 (dp `(end-env ,is-recursive (env-accumulator ,env-accumulator)))
575 (when is-recursive
576 (push-frame* env-accumulator)
577 (set! env-accumulator #f))
578 env)
580 (define (leave-env is-recursive v k)
581 (dp `(leave-env ,is-recursive ,v))
582 (when is-recursive
583 (pop-frame*))
584 (k v))
586 (define (update-env name old-annotation v)
587 (dp `(update-env ,name ,old-annotation ,v))
588 v)
590 (define (load-env name annotation v)
591 (dp `(load-env ,name ,annotation ,v))
592 (let ((loc (location-for-value annotation)))
593 (if (immediate? loc)
594 loc
595 (begin
596 (emit! (*mov-to-eax loc))
597 %eax))))
599 (define (unbound-variable-read name)
600 (dp `(load-implicit-global ,name))
601 (let ((symloc (load-literal name)))
602 (emit! (*mov (@ %eax 8) %eax)) ;; symbol's value -- FIXME, guessing about future
603 %eax))
605 (define (load-literal x)
606 (dp `(load-literal ,x))
607 (let ((value (cond
608 ((number? x) (+ 1 (* 4 x)))
609 ((symbol? x) #x42424242)
610 ((eq? x #t) (special-oop 'true))
611 ((eq? x #f) (special-oop 'false))
612 (else (error "Unsupported literal type" x)))))
613 ;;(emit! (*mov-to-eax value))
614 ;;%eax
615 value))
617 (define (load-closure formals f)
618 (dp `(load-closure ,formals))
619 (parameterize ((continuation-depth 0)
620 (instruction-rev-acc '())
621 (frame-depth 0)
622 (frame-stack '()))
623 (dp `=============================================)
624 (f (do ((number 0 (+ number 0))
625 (acc '() (cons (make-argument number) acc))
626 (formals formals (cdr formals)))
627 ((null? formals) (reverse acc)))
628 (lambda (v)
629 (dp `---------------------------------------------)
630 (emit! (*mov-to-eax v)
631 (*ret))
632 (get-native-function-addr
633 (simple-function (reverse (instruction-rev-acc))))))))
635 (define (do-if v tg fg k)
636 (let ((false-label (gensym "testfalse"))
637 (done-label (gensym "testdone")))
638 (dp `(do-if ,v))
639 (emit! (*op 'cmp (special-oop 'false) v)
640 (*jmp-cc 'e (make-label-reference false-label #f)))
641 (dp `tg)
642 (tg (lambda (true-v)
643 (emit! (*mov-to-eax true-v)
644 (*jmp (make-label-reference done-label #f))
645 (make-label-anchor false-label))
646 (dp `fg)
647 (fg (lambda (false-v)
648 (emit! (*mov-to-eax false-v)
649 (make-label-anchor done-label))
650 (dp `done-if)
651 (k %eax)))))))
653 (define (push-frame count k)
654 (dp `(push-frame ,count))
655 (push-frame* count)
656 k)
658 (define (update-frame index v)
659 (dp `(update-frame ,index ,v))
660 (let ((loc (@ %esp (* index 4))))
661 (emit! (*mov v loc))
662 loc))
664 (define (do-primitive names vals expressions k)
665 (dp `(%assemble ,names ,vals ,expressions))
666 (k 'primitive-result))
668 (define (do-call operator operands k)
669 (dp `(do-call ,(if (= (continuation-depth) 0)
670 'tailcall
671 'normalcall) ,operator ,operands))
672 (let ((loc (location-for-value operator)))
673 (if (immediate? loc)
674 ;; Always absolute
675 (emit! (*call (make-relocation loc)))
676 (emit! (*call loc))))
677 (pop-frame*)
678 (k %eax)) ;;;;;;'do-call-result))
680 (define (push-continuation k)
681 (continuation-depth (+ (continuation-depth) 1))
682 ;;(dp `(push-continuation ,(continuation-depth)))
683 (lambda (v)
684 ;;(dp `(pop-continuation ,(continuation-depth) ,v))
685 (continuation-depth (- (continuation-depth) 1))
686 (k v)))
688 ((make-eval error undefined begin-env allocate-env end-env leave-env update-env load-env
689 unbound-variable-read load-literal load-closure do-if push-frame update-frame
690 do-primitive do-call push-continuation)
691 exp))))
693 (define (t1)
694 (jit-compile '(lambda (num)
695 (= num 0))))
697 (define (t2)
698 (jit-compile '(lambda (num)
699 (define (f n) (if (zero? n) 1 (* n (f (- n 1)))))
700 (f num))))