1.1 --- a/experiments/codegen/codegen.scm	Mon Jul 27 21:52:23 2009 +0100
     1.2 +++ b/experiments/codegen/codegen.scm	Sat Oct 08 15:36:03 2011 -0400
     1.3 @@ -5,34 +5,101 @@
     1.4    `(if (null? ,(cadr form)) ,(caddr form) (car ,(cadr form))))
     1.5  (load "srfi-1.scm")
     1.6  
     1.7 -(define (relocation? x)
     1.8 -  (and (pair? x)
     1.9 -       (eq? (car x) 'relocation)))
    1.10 +(define (symbol-append . syms)
    1.11 +  (if (null? syms)
    1.12 +      (error "No symbols supplied to symbol-append")
    1.13 +      (string->symbol
    1.14 +       (fold-right (lambda (sym acc)
    1.15 +		     (if (zero? (string-length acc))
    1.16 +			 (symbol->string sym)
    1.17 +			 (string-append (symbol->string sym) acc)))
    1.18 +		   ""
    1.19 +		   syms))))
    1.20  
    1.21 -(define (relocation-target x)
    1.22 -  (cadr x))
    1.23 +(macro (cheap-struct form)
    1.24 +  (let ((record-name (cadr form))
    1.25 +	(field-names (caddr form)))
    1.26 +    (let ((maker-name (symbol-append 'make- record-name))
    1.27 +	  (predicate-name (symbol-append record-name '?)))
    1.28 +      `(begin
    1.29 +	 (define (,maker-name ,@field-names)
    1.30 +	   (vector ',record-name ,@field-names))
    1.31 +	 (define (,predicate-name x)
    1.32 +	   (and (vector? x)
    1.33 +		(eq? (vector-ref x 0) ',record-name)))
    1.34 +	 ,@(let loop ((field-names field-names)
    1.35 +		      (counter 1))
    1.36 +	     (if (null? field-names)
    1.37 +		 '()
    1.38 +		 (cons `(define (,(symbol-append record-name '- (car field-names)) x)
    1.39 +			  (vector-ref x ,counter))
    1.40 +		       (loop (cdr field-names) (+ counter 1)))))))))
    1.41 +
    1.42 +(define (filter-map-alist predicate transformer l)
    1.43 +  (filter-map (lambda (entry) (and (predicate (car entry))
    1.44 +				   (if transformer
    1.45 +				       (transformer (car entry) (cdr entry))
    1.46 +				       entry))) l))
    1.47 +
    1.48 +(cheap-struct relocation (target))
    1.49 +(cheap-struct label-reference (name is-8bit))
    1.50 +(cheap-struct label-anchor (name))
    1.51  
    1.52  (define (flatten-and-pre-relocate instrs k)
    1.53 -  (define (walk instrs acc pos relocs k)
    1.54 +  (define (walk instrs acc pos marks k)
    1.55      (if (null? instrs)
    1.56 -	(k acc pos relocs)
    1.57 +	(k acc pos marks)
    1.58  	(let ((instr (car instrs))
    1.59  	      (rest (cdr instrs)))
    1.60  	  (cond
    1.61 -	   ((relocation? instr) (walk rest acc pos (cons (cons instr pos) relocs) k))
    1.62 -	   ((list? instr) (walk instr acc pos relocs
    1.63 -				(lambda (acc pos relocs)
    1.64 -				  (walk rest acc pos relocs k))))
    1.65 -	   ((number? instr) (walk rest (cons instr acc) (+ pos 1) relocs k))
    1.66 +	   ((or (relocation? instr)
    1.67 +		(label-anchor? instr)
    1.68 +		(label-reference? instr))
    1.69 +	    (walk rest acc pos (cons (cons instr pos) marks) k))
    1.70 +	   ((list? instr) (walk instr acc pos marks
    1.71 +				(lambda (acc pos marks)
    1.72 +				  (walk rest acc pos marks k))))
    1.73 +	   ((number? instr) (walk rest (cons instr acc) (+ pos 1) marks k))
    1.74  	   ((string? instr) (walk rest
    1.75  				  (append (reverse (map char->integer (string->list instr))) acc)
    1.76  				  (+ pos (string-length instr))
    1.77 -				  relocs
    1.78 +				  marks
    1.79  				  k))
    1.80  	   (else (error "Invalid instruction in stream" instr))))))
    1.81    (walk instrs '() 0 '()
    1.82 -	(lambda (acc pos relocs)
    1.83 -	  (k (reverse acc) (reverse relocs)))))
    1.84 +	(lambda (reversed-code final-length reversed-marks)
    1.85 +	  (let* ((code (list->vector (reverse reversed-code)))
    1.86 +		 (marks (reverse reversed-marks))
    1.87 +		 (relocations (filter-map-alist relocation?
    1.88 +						(lambda (r p) (cons (relocation-target r) p))
    1.89 +						marks))
    1.90 +		 (anchors (filter-map-alist label-anchor?
    1.91 +					    (lambda (a p) (cons (label-anchor-name a) p))
    1.92 +					    marks))
    1.93 +		 (refs (filter-map-alist label-reference? #f marks)))
    1.94 +	    (define (anchor-pos name)
    1.95 +	      (cond
    1.96 +	       ((assq name anchors) => cdr)
    1.97 +	       (else (error "Undefined label-anchor" name))))
    1.98 +	    (write `(code ,code))(newline)
    1.99 +	    (write `(marks ,marks))(newline)
   1.100 +	    (for-each (lambda (entry)
   1.101 +			(let ((name (label-reference-name (car entry)))
   1.102 +			      (is-8bit (label-reference-is-8bit (car entry)))
   1.103 +			      (pos (cdr entry)))
   1.104 +			  (if is-8bit
   1.105 +			      (let ((delta (- (anchor-pos name) (+ pos 1))))
   1.106 +				(if (onebyte-immediate? delta)
   1.107 +				    (vector-set! code pos delta)
   1.108 +				    (error "Short jump out of range" entry)))
   1.109 +			      (let ((v (list->vector (imm32* (- (anchor-pos name) (+ pos 4))))))
   1.110 +				(vector-set! code (+ pos 0) (vector-ref v 0))
   1.111 +				(vector-set! code (+ pos 1) (vector-ref v 1))
   1.112 +				(vector-set! code (+ pos 2) (vector-ref v 2))
   1.113 +				(vector-set! code (+ pos 3) (vector-ref v 3))))))
   1.114 +		      refs)
   1.115 +	    (k code
   1.116 +	       relocations)))))
   1.117  
   1.118  (define (*ret) #xC3)
   1.119  
   1.120 @@ -59,6 +126,43 @@
   1.121  (define %esi 'esi)
   1.122  (define %edi 'edi)
   1.123  
   1.124 +(define condition-codes '#((o)
   1.125 +			   (no)
   1.126 +			   (b nae)
   1.127 +			   (nb ae)
   1.128 +			   (e z)
   1.129 +			   (ne nz)
   1.130 +			   (be na)
   1.131 +			   (nbe a)
   1.132 +			   (s)
   1.133 +			   (ns)
   1.134 +			   (p pe)
   1.135 +			   (np po)
   1.136 +			   (l nge)
   1.137 +			   (nl ge)
   1.138 +			   (le ng)
   1.139 +			   (nle g)))
   1.140 +
   1.141 +(define (condition-code-num code-sym)
   1.142 +  (let loop ((i 0))
   1.143 +    (cond
   1.144 +     ((>= i 16) (error "Invalid condition-code" code-sym))
   1.145 +     ((member code-sym (vector-ref condition-codes i)) i)
   1.146 +     (else (loop (+ i 1))))))
   1.147 +
   1.148 +(define specials '((undefined 0)
   1.149 +		   (true 1)
   1.150 +		   (false 2)
   1.151 +		   (nil 3)))
   1.152 +
   1.153 +(define (special-oop special-name)
   1.154 +  (cond
   1.155 +   ((assq special-name specials) =>
   1.156 +    (lambda (entry)
   1.157 +      (let ((special-num (cadr entry)))
   1.158 +	(+ 3 (* special-num 8)))))
   1.159 +   (else (error "Invalid special name" special-name))))
   1.160 +
   1.161  (define (register=? x y)
   1.162    (eq? x y))
   1.163  
   1.164 @@ -67,17 +171,8 @@
   1.165  
   1.166  (define (immediate? x)
   1.167    (or (number? x)
   1.168 -      (position-independent-immediate? x)))
   1.169 -
   1.170 -(define (position-independent-immediate? x)
   1.171 -  (and (pair? x)
   1.172 -       (eq? (car x) 'position-independent)))
   1.173 -
   1.174 -(define (position-independent x)
   1.175 -  (list 'position-independent x))
   1.176 -
   1.177 -(define (position-independent-address x)
   1.178 -  (cadr x))
   1.179 +      (relocation? x)
   1.180 +      (label-reference? x)))
   1.181  
   1.182  (define (memory? x)
   1.183    (and (pair? x)
   1.184 @@ -140,9 +235,8 @@
   1.185  	(modulo (shr i 24) 256)))
   1.186  
   1.187  (define (imm32 i)
   1.188 -  (if (position-independent-immediate? i)
   1.189 -      (let ((address (position-independent-address i)))
   1.190 -	(list `(relocation ,address) 0 0 0 0))
   1.191 +  (if (or (relocation? i) (label-reference? i))
   1.192 +      (list i 0 0 0 0)
   1.193        (imm32* i)))
   1.194  
   1.195  (define (imm32-if test-result i)
   1.196 @@ -226,7 +320,7 @@
   1.197  	  (list (bitfield 4 #b1011 1 w-bit 3 (reg-num target))
   1.198  		(imm32-if (= w-bit 1) source))
   1.199  	  (list (bitfield 2 3 3 0 2 3 1 w-bit)
   1.200 -		(mod-r-m opcode target)
   1.201 +		(mod-r-m 0 target)
   1.202  		(imm32-if (= w-bit 1) source))))
   1.203       ((memory? source)
   1.204        (cond
   1.205 @@ -250,14 +344,33 @@
   1.206       (else
   1.207        (error "*mov: Invalid source" (list source target))))))
   1.208  
   1.209 -(define (*call loc)
   1.210 +(define (*call-or-jmp-like immediate-opcode indirect-mod loc)
   1.211    (cond
   1.212     ((immediate? loc)
   1.213 -    (list #xE8 (imm32 loc)))
   1.214 +    (list immediate-opcode (imm32 loc)))
   1.215     ((or (register? loc) (memory? loc))
   1.216 -    (list #xFF (mod-r-m 2 loc)))
   1.217 +    (list #xFF (mod-r-m indirect-mod loc)))
   1.218     (else
   1.219 -    (error "*call: Invalid location" loc))))
   1.220 +    (error "*call/*jmp: Invalid location" loc))))
   1.221 +
   1.222 +(define (*call loc)
   1.223 +  (*call-or-jmp-like #xE8 2 loc))
   1.224 +
   1.225 +(define (is-short-jump? loc)
   1.226 +  (and (label-reference? loc)
   1.227 +       (label-reference-is-8bit loc)))
   1.228 +
   1.229 +(define (*jmp loc)
   1.230 +  (if (is-short-jump? loc)
   1.231 +      (list #xEB loc 0)
   1.232 +      (*call-or-jmp-like #xE9 4 loc)))
   1.233 +
   1.234 +(define (*jmp-cc code loc)
   1.235 +  (write `(*jmp-cc ,code ,loc))(newline)
   1.236 +  (let ((tttn (condition-code-num code)))
   1.237 +    (if (is-short-jump? loc)
   1.238 +	(list (bitfield 4 7 4 tttn) loc 0)
   1.239 +	(list #x0F (bitfield 4 8 4 tttn) (imm32 loc)))))
   1.240  
   1.241  (define (push32 reg)
   1.242    (mod-r-m* 1 2 (reg-num reg)))
   1.243 @@ -273,7 +386,7 @@
   1.244  	(pop32 reg)))
   1.245  
   1.246  (define (code->binary codevec)
   1.247 -  (list->string (map integer->char codevec)))
   1.248 +  (list->string (map integer->char (vector->list codevec))))
   1.249  
   1.250  (define (simple-function . instrs)
   1.251    (flatten-and-pre-relocate
   1.252 @@ -321,7 +434,7 @@
   1.253     (_CAR) ;; function pointer is in car slot
   1.254     (*mov %ecx (@ %esp 0))
   1.255     (*mov %eax (@ %esp 4))
   1.256 -   (*call (position-independent mk_integer-addr))))
   1.257 +   (*call (make-relocation mk_integer-addr))))
   1.258  
   1.259  (define puts-addr (lookup-native-symbol "puts"))
   1.260  (define puts (prelude-function 4
   1.261 @@ -332,7 +445,7 @@
   1.262  
   1.263  	      ;(*mov puts-addr %eax)
   1.264  	      ;(*call %eax)
   1.265 -	      (*call (position-independent puts-addr))
   1.266 +	      (*call (make-relocation puts-addr))
   1.267  
   1.268  	      (*mov (@ %ebp 12) %eax)))
   1.269  
   1.270 @@ -367,66 +480,222 @@
   1.271  
   1.272  (define-global! 'jit-compile
   1.273    (lambda (exp)
   1.274 -    (let ((continuation-depth (make-parameter 0)))
   1.275 -      (define (error key val) (12345678 'magic-error-procedure key val))
   1.276 -      (define (undefined) (load-literal 17))
   1.277 +    (let ((env-accumulator #f)
   1.278 +
   1.279 +	  (continuation-depth (make-parameter 0))
   1.280 +	  (instruction-rev-acc (make-parameter '()))
   1.281 +	  (frame-depth (make-parameter 0))
   1.282 +	  (frame-stack (make-parameter '())))
   1.283 +
   1.284 +      (define (dp term)
   1.285 +	(display (make-string (* 2 (length (frame-stack))) #\ ))
   1.286 +	(write term)
   1.287 +	(newline))
   1.288 +
   1.289 +      ;; -- Data types used to represent partial values
   1.290 +
   1.291 +      (cheap-struct argument (number))
   1.292 +      (cheap-struct literal (number))
   1.293 +      (cheap-struct recursive-binding (number frame-depth))
   1.294 +
   1.295 +      ;; -- Interface to assembler
   1.296 +
   1.297 +      (define (emit! . instrs)
   1.298 +	(dp `(emit! ,@instrs))
   1.299 +	(instruction-rev-acc (cons instrs (instruction-rev-acc))))
   1.300 +
   1.301 +      (define (*mov-to-eax source)
   1.302 +	(if (and (register? source)
   1.303 +		 (register=? source %eax))
   1.304 +	    '()
   1.305 +	    (*mov source %eax)))
   1.306 +
   1.307 +      (define (location-for-value v)
   1.308 +	(cond
   1.309 +	 ((argument? v) (@ %esp (+ (frame-depth) (* (+ (argument-number v) 1) 4))))
   1.310 +	 ((literal? v) (literal-number v))
   1.311 +	 ((recursive-binding? v) (@ %esp (+ (- (frame-depth) (recursive-binding-frame-depth v))
   1.312 +					    (* (+ (recursive-binding-number v) 1) -4))))
   1.313 +	 ((or (register? v) (memory? v) (immediate? v)) v)
   1.314 +	 (else (error "Invalid PE value" v))))
   1.315 +
   1.316 +      (define (move-esp-by! slot-count)
   1.317 +	(when (not (zero? slot-count))
   1.318 +	  (let ((nbytes (abs (* slot-count 4))))
   1.319 +	    (emit! (*op (if (positive? slot-count) 'add 'sub) nbytes %esp))
   1.320 +	    (frame-depth ((if (positive? slot-count) - +) (frame-depth) nbytes)))))
   1.321 +
   1.322 +      (define (allocate! nwords)
   1.323 +	(let ((ok-label (gensym "allocok")))
   1.324 +	  (emit! (*mov %esi %eax)
   1.325 +		 (*op 'add (* nwords 4) %esi)
   1.326 +		 (*op 'cmp %esi %edi)
   1.327 +		 (*jmp-cc 'ge (make-label-reference ok-label #t))
   1.328 +		 (*mov %eax %esi)
   1.329 +		 (*mov (* nwords 4) %eax))
   1.330 +	  (trap! 0)
   1.331 +	  (emit! (make-label-anchor ok-label))))
   1.332 +
   1.333 +      (define (push-frame* count)
   1.334 +	(dp `(push-frame* ,count (frame-stack ,(frame-stack))))
   1.335 +	(when (positive? count)
   1.336 +	  (move-esp-by! (- count)))
   1.337 +	(frame-stack (cons count (frame-stack))))
   1.338 +
   1.339 +      (define (pop-frame*)
   1.340 +	(dp `(pop-frame* (frame-stack ,(frame-stack))))
   1.341 +	(let ((count (car (frame-stack))))
   1.342 +	  (when (positive? count)
   1.343 +	    (move-esp-by! (car (frame-stack))))
   1.344 +	  (frame-stack (cdr (frame-stack)))))
   1.345 +
   1.346 +      ;; -- Interpreter-core API
   1.347 +
   1.348 +      ;;(define (error key val)
   1.349 +      ;;...?)
   1.350 +
   1.351 +      (define (undefined)
   1.352 +	(special-oop 'undefined))
   1.353 +
   1.354 +      (define (begin-env is-recursive env)
   1.355 +	(dp `(begin-env ,is-recursive))
   1.356 +	(set! env-accumulator (if is-recursive 0 #f))
   1.357 +	env)
   1.358 +
   1.359        (define (allocate-env name v)
   1.360 -	(write `(allocate-env ,name ,v)) (newline)
   1.361 -	'local)
   1.362 +	(dp `(allocate-env ,name ,v))
   1.363 +	(if env-accumulator
   1.364 +	    (let ((a (make-recursive-binding env-accumulator (frame-depth))))
   1.365 +	      (set! env-accumulator (+ env-accumulator 1))
   1.366 +	      a)
   1.367 +	    (or v (undefined))))
   1.368 +
   1.369 +      (define (end-env is-recursive env)
   1.370 +	(dp `(end-env ,is-recursive (env-accumulator ,env-accumulator)))
   1.371 +	(when is-recursive
   1.372 +	  (push-frame* env-accumulator)
   1.373 +	  (set! env-accumulator #f))
   1.374 +	env)
   1.375 +
   1.376 +      (define (leave-env is-recursive v k)
   1.377 +	(dp `(leave-env ,is-recursive ,v))
   1.378 +	(when is-recursive
   1.379 +	  (pop-frame*))
   1.380 +	(k v))
   1.381 +
   1.382        (define (update-env name old-annotation v)
   1.383 -	(write `(update-env ,name ,old-annotation)) (newline)
   1.384 -	old-annotation)
   1.385 +	(dp `(update-env ,name ,old-annotation ,v))
   1.386 +	v)
   1.387 +
   1.388        (define (load-env name annotation v)
   1.389 -	(write `(load-env ,name ,annotation)) (newline)
   1.390 -	v)
   1.391 +	(dp `(load-env ,name ,annotation ,v))
   1.392 +	(let ((loc (location-for-value annotation)))
   1.393 +	  (if (immediate? loc)
   1.394 +	      loc
   1.395 +	      (begin
   1.396 +		(emit! (*mov-to-eax loc))
   1.397 +		%eax))))
   1.398 +
   1.399        (define (unbound-variable-read name)
   1.400 -	(write `(load-implicit-global ,name)) (newline)
   1.401 -	'implicit-global-value)
   1.402 +	(dp `(load-implicit-global ,name))
   1.403 +	(let ((symloc (load-literal name)))
   1.404 +	  (emit! (*mov (@ %eax 8) %eax)) ;; symbol's value -- FIXME, guessing about future
   1.405 +	  %eax))
   1.406 +
   1.407        (define (load-literal x)
   1.408 -	(write `(load-literal ,x)) (newline)
   1.409 -	x)
   1.410 +	(dp `(load-literal ,x))
   1.411 +	(let ((value (cond
   1.412 +		      ((number? x) (+ 1 (* 4 x)))
   1.413 +		      ((symbol? x) #x42424242)
   1.414 +		      ((eq? x #t) (special-oop 'true))
   1.415 +		      ((eq? x #f) (special-oop 'false))
   1.416 +		      (else (error "Unsupported literal type" x)))))
   1.417 +	  ;;(emit! (*mov-to-eax value))
   1.418 +	  ;;%eax
   1.419 +	  value))
   1.420 +
   1.421        (define (load-closure formals f)
   1.422 -	(write `(load-closure ,formals)) (newline)
   1.423 -	(parameterize ((continuation-depth 0))
   1.424 -	  (write `(IN================)) (newline)
   1.425 -	  (f formals (lambda (v)
   1.426 -		       (write `(return)) (newline)
   1.427 -		       v))
   1.428 -	  (write `(OUT===============)) (newline)
   1.429 -	  'closure-result))
   1.430 -      (define (do-if v tk fk)
   1.431 -	(write `(do-if ,v)) (newline)
   1.432 -	(write `tk) (newline)
   1.433 -	(tk)
   1.434 -	(write `fk) (newline)
   1.435 -	(fk))
   1.436 +	(dp `(load-closure ,formals))
   1.437 +	(parameterize ((continuation-depth 0)
   1.438 +		       (instruction-rev-acc '())
   1.439 +		       (frame-depth 0)
   1.440 +		       (frame-stack '()))
   1.441 +	  (dp `=============================================)
   1.442 +	  (f (do ((number 0 (+ number 0))
   1.443 +		  (acc '() (cons (make-argument number) acc))
   1.444 +		  (formals formals (cdr formals)))
   1.445 +		 ((null? formals) (reverse acc)))
   1.446 +	     (lambda (v)
   1.447 +	       (dp `---------------------------------------------)
   1.448 +	       (emit! (*mov-to-eax v)
   1.449 +		      (*ret))
   1.450 +	       (get-native-function-addr
   1.451 +		(simple-function (reverse (instruction-rev-acc))))))))
   1.452 +
   1.453 +      (define (do-if v tg fg k)
   1.454 +	(let ((false-label (gensym "testfalse"))
   1.455 +	      (done-label (gensym "testdone")))
   1.456 +	  (dp `(do-if ,v))
   1.457 +	  (emit! (*op 'cmp (special-oop 'false) v)
   1.458 +		 (*jmp-cc 'e (make-label-reference false-label #f)))
   1.459 +	  (dp `tg)
   1.460 +	  (tg (lambda (true-v)
   1.461 +		(emit! (*mov-to-eax true-v)
   1.462 +		       (*jmp (make-label-reference done-label #f))
   1.463 +		       (make-label-anchor false-label))
   1.464 +		(dp `fg)
   1.465 +		(fg (lambda (false-v)
   1.466 +		      (emit! (*mov-to-eax false-v)
   1.467 +			     (make-label-anchor done-label))
   1.468 +		      (dp `done-if)
   1.469 +		      (k %eax)))))))
   1.470 +
   1.471        (define (push-frame count k)
   1.472 -	(write `(push-frame ,count)) (newline)
   1.473 +	(dp `(push-frame ,count))
   1.474 +	(push-frame* count)
   1.475  	k)
   1.476 +
   1.477        (define (update-frame index v)
   1.478 -	(write `(update-frame ,index ,v)) (newline)
   1.479 -	v)
   1.480 +	(dp `(update-frame ,index ,v))
   1.481 +	(let ((loc (@ %esp (* index 4))))
   1.482 +	  (emit! (*mov v loc))
   1.483 +	  loc))
   1.484 +
   1.485        (define (do-primitive names vals expressions k)
   1.486 -	(write `(%assemble ,names ,vals ,expressions))
   1.487 +	(dp `(%assemble ,names ,vals ,expressions))
   1.488  	(k 'primitive-result))
   1.489 +
   1.490        (define (do-call operator operands k)
   1.491 -	(write `(do-call ,(if (= (continuation-depth) 0)
   1.492 +	(dp `(do-call ,(if (= (continuation-depth) 0)
   1.493  			      'tailcall
   1.494  			      'normalcall) ,operator ,operands))
   1.495 -	(newline)
   1.496 -	(k 'do-call-result))
   1.497 +	(let ((loc (location-for-value operator)))
   1.498 +	  (if (immediate? loc)
   1.499 +	      ;; Always absolute
   1.500 +	      (emit! (*call (make-relocation loc)))
   1.501 +	      (emit! (*call loc))))
   1.502 +	(pop-frame*)
   1.503 +	(k %eax)) ;;;;;;'do-call-result))
   1.504 +
   1.505        (define (push-continuation k)
   1.506 -	;;(write `(push-continuation)) (newline)
   1.507  	(continuation-depth (+ (continuation-depth) 1))
   1.508 +	;;(dp `(push-continuation ,(continuation-depth)))
   1.509  	(lambda (v)
   1.510 -	  ;;(write `(pop-continuation ,v)) (newline)
   1.511 +	  ;;(dp `(pop-continuation ,(continuation-depth) ,v))
   1.512  	  (continuation-depth (- (continuation-depth) 1))
   1.513  	  (k v)))
   1.514 -      ((make-eval error undefined allocate-env update-env load-env unbound-variable-read
   1.515 -		  load-literal load-closure do-if push-frame update-frame
   1.516 +
   1.517 +      ((make-eval error undefined begin-env allocate-env end-env leave-env update-env load-env
   1.518 +		  unbound-variable-read load-literal load-closure do-if push-frame update-frame
   1.519  		  do-primitive do-call push-continuation)
   1.520         exp))))
   1.521  
   1.522 -(jit-compile '(lambda (num)
   1.523 -		(define (f n) (if (zero? n) 1 (* n (f (- n 1)))))
   1.524 -		(f num)))
   1.525 +(define (t1)
   1.526 +  (jit-compile '(lambda (num)
   1.527 +		  (= num 0))))
   1.528 +
   1.529 +(define (t2)
   1.530 +  (jit-compile '(lambda (num)
   1.531 +		  (define (f n) (if (zero? n) 1 (* n (f (- n 1)))))
   1.532 +		  (f num))))
   1.533 +