| blob | 7ab16f5b1350f8a9b644391bc9ddf6127cf3ce53 |
1 ;;;; File: "picobit.scm", Time-stamp: <2006-05-08 16:04:37 feeley>
3 ;;;; Copyright (C) 2004-2009 by Marc Feeley and Vincent St-Amour
4 ;;;; All Rights Reserved.
6 (define-macro (dummy)
7 (proper-tail-calls-set! #f)
8 #f)
9 ;(dummy)
11 ;-----------------------------------------------------------------------------
13 (define compiler-error
14 (lambda (msg . others)
15 (display "*** ERROR -- ")
16 (display msg)
17 (for-each (lambda (x) (display " ") (write x)) others)
18 (newline)
19 (exit 1)))
21 ;-----------------------------------------------------------------------------
23 (define keep
24 (lambda (keep? lst)
25 (cond ((null? lst) '())
26 ((keep? (car lst)) (cons (car lst) (keep keep? (cdr lst))))
27 (else (keep keep? (cdr lst))))))
29 (define take
30 (lambda (n lst)
31 (if (> n 0)
32 (cons (car lst) (take (- n 1) (cdr lst)))
33 '())))
35 (define drop
36 (lambda (n lst)
37 (if (> n 0)
38 (drop (- n 1) (cdr lst))
39 lst)))
41 (define repeat
42 (lambda (n x)
43 (if (> n 0)
44 (cons x (repeat (- n 1) x))
45 '())))
47 (define pos-in-list
48 (lambda (x lst)
49 (let loop ((lst lst) (i 0))
50 (cond ((not (pair? lst)) #f)
51 ((eq? (car lst) x) i)
52 (else (loop (cdr lst) (+ i 1)))))))
54 (define every
55 (lambda (pred? lst)
56 (or (null? lst)
57 (and (pred? (car lst))
58 (every pred? (cdr lst))))))
60 ;-----------------------------------------------------------------------------
62 ;; Syntax-tree node representation.
64 (define-type node
65 extender: define-type-of-node
66 (parent unprintable:)
67 children
68 )
70 (define-type-of-node cst
71 val
72 )
74 (define-type-of-node ref
75 var
76 )
78 (define-type-of-node def
79 var
80 )
82 (define-type-of-node set
83 var
84 )
86 (define-type-of-node if
87 )
89 (define-type-of-node prc
90 params
91 rest?
92 entry-label
93 )
95 (define-type-of-node call
96 )
98 (define-type-of-node seq
99 )
101 (define-type-of-node fix
102 vars
103 )
105 (define node->expr
106 (lambda (node)
107 (cond ((cst? node)
108 (let ((val (cst-val node)))
109 (if (self-eval? val)
110 val
111 (list 'quote val))))
112 ((ref? node)
113 (var-id (ref-var node)))
114 ((def? node)
115 (list 'define
116 (var-id (def-var node))
117 (node->expr (child1 node))))
118 ((set? node)
119 (list 'set!
120 (var-id (set-var node))
121 (node->expr (child1 node))))
122 ((if? node)
123 (list 'if
124 (node->expr (child1 node))
125 (node->expr (child2 node))
126 (node->expr (child3 node))))
127 ((prc? node)
128 (if (seq? (child1 node))
129 (cons 'lambda
130 (cons (build-pattern (prc-params node) (prc-rest? node))
131 (nodes->exprs (node-children (child1 node)))))
132 (list 'lambda
133 (build-pattern (prc-params node) (prc-rest? node))
134 (node->expr (child1 node)))))
135 ((call? node)
136 (map node->expr (node-children node)))
137 ((seq? node)
138 (let ((children (node-children node)))
139 (cond ((null? children)
140 '(void))
141 ((null? (cdr children))
142 (node->expr (car children)))
143 (else
144 (cons 'begin
145 (nodes->exprs children))))))
146 ((fix? node)
147 (let ((children (node-children node)))
148 (list 'letrec
149 (map (lambda (var val)
150 (list (var-id var)
151 (node->expr val)))
152 (fix-vars node)
153 (take (- (length children) 1) children))
154 (node->expr (list-ref children (- (length children) 1))))))
155 (else
156 (compiler-error "unknown expression type" node)))))
158 (define nodes->exprs
159 (lambda (nodes)
160 (if (null? nodes)
161 '()
162 (if (seq? (car nodes))
163 (append (nodes->exprs (node-children (car nodes)))
164 (nodes->exprs (cdr nodes)))
165 (cons (node->expr (car nodes))
166 (nodes->exprs (cdr nodes)))))))
168 (define build-pattern
169 (lambda (params rest?)
170 (cond ((null? params)
171 '())
172 ((null? (cdr params))
173 (if rest?
174 (var-id (car params))
175 (list (var-id (car params)))))
176 (else
177 (cons (var-id (car params))
178 (build-pattern (cdr params) rest?))))))
180 ;-----------------------------------------------------------------------------
182 ;; Environment representation.
184 (define-type var
185 id
186 global?
187 (refs unprintable:)
188 (sets unprintable:)
189 (defs unprintable:)
190 needed?
191 primitive
192 )
194 (define-type primitive
195 nargs
196 inliner
197 unspecified-result?
198 )
200 (define-type renaming
201 renamings
202 )
204 (define make-global-env
205 (lambda ()
206 (list
207 (make-var '#%number? #t '() '() '() #f (make-primitive 1 #f #f))
208 (make-var '#%+ #t '() '() '() #f (make-primitive 2 #f #f))
209 (make-var '#%- #t '() '() '() #f (make-primitive 2 #f #f))
210 (make-var '#%* #t '() '() '() #f (make-primitive 2 #f #f))
211 (make-var '#%quotient #t '() '() '() #f (make-primitive 2 #f #f))
212 (make-var '#%remainder #t '() '() '() #f (make-primitive 2 #f #f))
213 (make-var '#%neg #t '() '() '() #f (make-primitive 1 #f #f))
214 (make-var '#%= #t '() '() '() #f (make-primitive 2 #f #f))
215 (make-var '#%< #t '() '() '() #f (make-primitive 2 #f #f))
216 (make-var '#%ior #t '() '() '() #f (make-primitive 2 #f #f))
217 (make-var '#%> #t '() '() '() #f (make-primitive 2 #f #f))
218 (make-var '#%xor #t '() '() '() #f (make-primitive 2 #f #f))
219 (make-var '#%pair? #t '() '() '() #f (make-primitive 1 #f #f))
220 (make-var '#%cons #t '() '() '() #f (make-primitive 2 #f #f))
221 (make-var '#%car #t '() '() '() #f (make-primitive 1 #f #f))
222 (make-var '#%cdr #t '() '() '() #f (make-primitive 1 #f #f))
223 (make-var '#%set-car! #t '() '() '() #f (make-primitive 2 #f #t))
224 (make-var '#%set-cdr! #t '() '() '() #f (make-primitive 2 #f #t))
225 (make-var '#%null? #t '() '() '() #f (make-primitive 1 #f #f))
226 (make-var '#%eq? #t '() '() '() #f (make-primitive 2 #f #f))
227 (make-var '#%not #t '() '() '() #f (make-primitive 1 #f #f))
228 (make-var '#%get-cont #t '() '() '() #f (make-primitive 0 #f #f))
229 (make-var '#%graft-to-cont #t '() '() '() #f (make-primitive 2 #f #f))
230 (make-var '#%return-to-cont #t '() '() '() #f (make-primitive 2 #f #f))
231 (make-var '#%halt #t '() '() '() #f (make-primitive 0 #f #t))
232 (make-var '#%symbol? #t '() '() '() #f (make-primitive 1 #f #f))
233 (make-var '#%string? #t '() '() '() #f (make-primitive 1 #f #f))
234 (make-var '#%string->list #t '() '() '() #f (make-primitive 1 #f #f))
235 (make-var '#%list->string #t '() '() '() #f (make-primitive 1 #f #f))
236 (make-var '#%make-u8vector #t '() '() '() #f (make-primitive 2 #f #f))
237 (make-var '#%u8vector-ref #t '() '() '() #f (make-primitive 2 #f #f))
238 (make-var '#%u8vector-set! #t '() '() '() #f (make-primitive 3 #f #t))
239 (make-var '#%print #t '() '() '() #f (make-primitive 1 #f #t))
240 (make-var '#%clock #t '() '() '() #f (make-primitive 0 #f #f))
241 (make-var '#%motor #t '() '() '() #f (make-primitive 2 #f #t))
242 (make-var '#%led #t '() '() '() #f (make-primitive 3 #f #t))
243 (make-var '#%led2-color #t '() '() '() #f (make-primitive 1 #f #t))
244 (make-var '#%getchar-wait #t '() '() '() #f (make-primitive 2 #f #f))
245 (make-var '#%putchar #t '() '() '() #f (make-primitive 2 #f #t))
246 (make-var '#%beep #t '() '() '() #f (make-primitive 2 #f #f))
247 (make-var '#%adc #t '() '() '() #f (make-primitive 1 #f #f))
248 (make-var '#%u8vector? #t '() '() '() #f (make-primitive 1 #f #f))
249 (make-var '#%sernum #t '() '() '() #f (make-primitive 0 #f #f))
250 (make-var '#%u8vector-length #t '() '() '() #f (make-primitive 1 #f #f))
251 (make-var '#%u8vector-copy! #t '() '() '() #f (make-primitive 5 #f #t))
252 (make-var '#%boolean? #t '() '() '() #f (make-primitive 1 #f #f))
253 (make-var '#%network-init #t '() '() '() #f (make-primitive 0 #f #t))
254 (make-var '#%network-cleanup #t '() '() '() #f (make-primitive 0 #f #t))
255 (make-var '#%receive-packet-to-u8vector #t '() '() '() #f (make-primitive 1 #f #f))
256 (make-var '#%send-packet-from-u8vector #t '() '() '() #f (make-primitive 2 #f #f))
257 (make-var '#%<= #t '() '() '() #f (make-primitive 2 #f #f))
258 (make-var '#%>= #t '() '() '() #f (make-primitive 2 #f #f))
260 (make-var '#%readyq #t '() '() '() #f #f)
261 ;; TODO put in a meaningful order
262 )))
264 ;; list of primitives that can be safely substituted for the equivalent
265 ;; function when it is called.
266 ;; this saves the calls to the primitive wrapper functions, which are still
267 ;; needed if a program needs the value of a "primitive", for example in :
268 ;; (define foo car)
269 (define substitute-primitives
270 '((number? . #%number?)
271 (quotient . #%quotient)
272 (remainder . #%remainder)
273 (= . #%=)
274 (< . #%<)
275 (> . #%>)
276 (<= . #%<=)
277 (>= . #%>=)
278 (pair? . #%pair?)
279 (cons . #%cons)
280 (car . #%car)
281 (cdr . #%cdr)
282 (set-car! . #%set-car!)
283 (set-cdr! . #%set-cdr!)
284 (null? . #%null?)
285 (eq? . #%eq?)
286 (not . #%not)
287 (modulo . #%remainder)
288 (symbol? . #%symbol?)
289 (string? . #%string?)
290 (string->list . #%string->list)
291 (list->string . #%list->string)
292 (clock . #%clock)
293 (beep . #%beep)
294 (light . #%adc)
295 (adc . #%adc)
296 (sernum . #%sernum)
297 (motor . #%motor)
298 (led . #%led)
299 (bitwise-ior . #%ior)
300 (bitwise-xor . #%xor)
301 (current-time . #%clock)
302 (u8vector-length . #%u8vector-length)
303 (u8vector-ref . #%u8vector-ref)
304 (u8vector-set! . #%u8vector-set!)
305 (make-u8vector . #%make-u8vector)
306 (u8vector-copy! . #%u8vector-copy!)
307 (boolean? . #%boolean?)
308 (network-init . #%network-init)
309 (network-cleanup . #%network-cleanup)
310 (receive-packet-to-u8vector . #%receive-packet-to-u8vector)
311 (send-packet-from-u8vector . #%send-packet-from-u8vector)
312 ))
314 (define env-lookup
315 (lambda (env id)
316 (let loop ((lst env) (id id))
317 (let ((b (car lst)))
318 (cond ((and (renaming? b)
319 (assq id (renaming-renamings b)))
320 =>
321 (lambda (x)
322 (loop (cdr lst) (cadr x))))
323 ((and (var? b)
324 (eq? (var-id b) id))
325 b)
326 ((null? (cdr lst))
327 (let ((x (make-var id #t '() '() '() #f #f)))
328 (set-cdr! lst (cons x '()))
329 x))
330 (else
331 (loop (cdr lst) id)))))))
333 (define env-extend
334 (lambda (env ids def)
335 (append (map (lambda (id)
336 (make-var id #f '() '() (list def) #f #f))
337 ids)
338 env)))
340 (define env-extend-renamings
341 (lambda (env renamings)
342 (cons (make-renaming renamings) env)))
344 (define *macros* '())
346 ;-----------------------------------------------------------------------------
348 ;; Parsing.
350 (define parse-program
351 (lambda (expr env)
352 (let ((x (parse-top expr env)))
353 (cond ((null? x)
354 (parse 'value #f env))
355 ((null? (cdr x))
356 (car x))
357 (else
358 (let ((r (make-seq #f x)))
359 (for-each (lambda (y) (node-parent-set! y r)) x)
360 r))))))
362 (define parse-top
363 (lambda (expr env)
364 (cond ((and (pair? expr)
365 (eq? (car expr) 'define-macro))
366 (set! *macros*
367 (cons (cons (caadr expr)
368 (eval `(lambda ,(cdadr expr) . ,(cddr expr))))
369 *macros*))
370 '())
371 ((and (pair? expr)
372 (eq? (car expr) 'begin))
373 (parse-top-list (cdr expr) env))
374 ((and (pair? expr)
375 (eq? (car expr) 'hide))
376 (parse-top-hide (cadr expr) (cddr expr) env))
377 ((and (pair? expr)
378 (eq? (car expr) 'rename))
379 (parse-top-rename (cadr expr) (cddr expr) env))
380 ((and (pair? expr)
381 (eq? (car expr) 'define))
382 (let ((var
383 (if (pair? (cadr expr))
384 (car (cadr expr))
385 (cadr expr)))
386 (val
387 (if (pair? (cadr expr))
388 (cons 'lambda (cons (cdr (cadr expr)) (cddr expr)))
389 (caddr expr))))
390 (let* ((var2 (env-lookup env var))
391 (val2 (parse 'value val env))
392 (r (make-def #f (list val2) var2)))
393 (node-parent-set! val2 r)
394 (var-defs-set! var2 (cons r (var-defs var2)))
395 (list r))))
396 (else
397 (list (parse 'value expr env))))))
399 (define parse-top-list
400 (lambda (lst env)
401 (if (pair? lst)
402 (append (parse-top (car lst) env)
403 (parse-top-list (cdr lst) env))
404 '())))
406 (define parse-top-hide
407 (lambda (renamings body env)
408 (append
409 (parse-top-list body
410 (env-extend-renamings env renamings))
411 ;; (parse-top-list
412 ;; (map (lambda (x) (list 'define (car x) (cadr x))) renamings)
413 ;; env)
414 )))
416 (define parse-top-rename
417 (lambda (renamings body env)
418 (parse-top-list body
419 (env-extend-renamings env renamings))))
421 (define parse
422 (lambda (use expr env)
423 (cond ((self-eval? expr)
424 (make-cst #f '() expr))
425 ((symbol? expr)
426 (let* ((var (env-lookup env expr))
427 (r (make-ref #f '() var)))
428 (var-refs-set! var (cons r (var-refs var)))
429 (if (not (var-global? var))
430 (let* ((unbox (parse 'value '#%unbox env))
431 (app (make-call #f (list unbox r))))
432 (node-parent-set! r app)
433 (node-parent-set! unbox app)
434 app)
435 r)))
436 ((and (pair? expr)
437 (assq (car expr) *macros*))
438 => (lambda (p) (parse use (apply (cdr p) (cdr expr)) env)))
439 ((and (pair? expr)
440 (eq? (car expr) 'set!))
441 (let ((var (env-lookup env (cadr expr))))
442 (if (var-global? var)
443 (let* ((val (parse 'value (caddr expr) env))
444 (r (make-set #f (list val) var)))
445 (node-parent-set! val r)
446 (var-sets-set! var (cons r (var-sets var)))
447 r)
448 (let* ((body (parse 'value (caddr expr) env))
449 (ref (make-ref #f '() var))
450 (bs (make-ref #f '() (env-lookup env '#%box-set!)))
451 (r (make-call #f (list bs ref body))))
452 (node-parent-set! body r)
453 (node-parent-set! ref r)
454 (node-parent-set! bs r)
455 (var-sets-set! var (cons r (var-sets var)))
456 r))))
457 ((and (pair? expr)
458 (eq? (car expr) 'quote))
459 (make-cst #f '() (cadr expr)))
460 ((and (pair? expr)
461 (eq? (car expr) 'if))
462 (let* ((a (parse 'test (cadr expr) env))
463 (b (parse use (caddr expr) env))
464 (c (if (null? (cdddr expr))
465 (make-cst #f '() #f)
466 (parse use (cadddr expr) env)))
467 (r (make-if #f (list a b c))))
468 (node-parent-set! a r)
469 (node-parent-set! b r)
470 (node-parent-set! c r)
471 r))
472 ((and (pair? expr)
473 (eq? (car expr) 'lambda))
474 (let* ((pattern (cadr expr))
475 (ids (extract-ids pattern))
476 ;; parent children params rest? entry-label
477 (r (make-prc #f '() #f (has-rest-param? pattern) #f))
478 (new-env (env-extend env ids r))
479 (body (parse-body (cddr expr) new-env))
480 (mut-vars
481 (apply append
482 (map (lambda (id)
483 (let ((v (env-lookup new-env id)))
484 (if (mutable-var? v) (list v) '())))
485 ids))))
486 (if (null? mut-vars)
487 (begin
488 (prc-params-set! r
489 (map (lambda (id) (env-lookup new-env id))
490 ids))
491 (node-children-set! r (list body))
492 (node-parent-set! body r)
493 r)
494 (let* ((prc (make-prc #f (list body) mut-vars #f #f))
495 (new-vars (map var-id mut-vars))
496 (tmp-env (env-extend env new-vars r))
497 (app
498 (make-call
499 r
500 (cons prc
501 (map (lambda (id)
502 (parse 'value
503 (cons '#%box (cons id '()))
504 tmp-env))
505 new-vars)))))
506 ;; (lambda (a b) (set! a b))
507 ;; => (lambda (_a b) ((lambda (a) (box-set! a b)) (box _a)))
508 (for-each (lambda (var) (var-defs-set! var (list prc)))
509 mut-vars)
510 (for-each (lambda (n) (node-parent-set! n app))
511 (cdr (node-children app)))
512 (node-parent-set! prc app)
513 (prc-params-set! r
514 (map (lambda (id) (env-lookup tmp-env id))
515 ids))
516 (node-children-set! r (list app))
517 (node-parent-set! body prc)
518 r))))
519 ((and (pair? expr)
520 (eq? (car expr) 'letrec))
521 (let ((ks (map car (cadr expr)))
522 (vs (map cadr (cadr expr))))
523 (parse use
524 (cons 'let
525 (cons (map (lambda (k) (list k #f)) ks)
526 (append (map (lambda (k v) (list 'set! k v))
527 ks vs) ; letrec*
528 (cddr expr))))
529 env)))
530 ((and (pair? expr)
531 (eq? (car expr) 'begin))
532 (let* ((exprs (map (lambda (x) (parse 'value x env)) (cdr expr)))
533 (r (make-seq #f exprs)))
534 (for-each (lambda (x) (node-parent-set! x r)) exprs)
535 r))
536 ((and (pair? expr)
537 (eq? (car expr) 'let))
538 (if (symbol? (cadr expr))
539 (parse use
540 `(letrec ((,(cadr expr) (lambda ,(map car (caddr expr)) .
541 ,(cdddr expr))))
542 (,(cadr expr) . ,(map cadr (caddr expr))))
543 env)
544 (parse use
545 (cons (cons 'lambda
546 (cons (map car (cadr expr))
547 (cddr expr)))
548 (map cadr (cadr expr)))
549 env)))
550 ((and (pair? expr)
551 (eq? (car expr) 'let*))
552 (if (null? (cadr expr))
553 (parse use
554 (cons 'let (cdr expr))
555 env)
556 (parse use
557 (list 'let
558 (list (list (caar (cadr expr))
559 (cadar (cadr expr))))
560 (cons 'let*
561 (cons (cdr (cadr expr))
562 (cddr expr))))
563 env)))
564 ((and (pair? expr)
565 (eq? (car expr) 'and))
566 (cond ((null? (cdr expr))
567 (parse use
568 #t
569 env))
570 ((null? (cddr expr))
571 (parse use
572 (cadr expr)
573 env))
574 (else
575 (parse use
576 (list 'if
577 (cadr expr)
578 (cons 'and (cddr expr))
579 #f)
580 env))))
581 ((and (pair? expr)
582 (eq? (car expr) 'or))
583 (cond ((null? (cdr expr))
584 (parse use
585 #f
586 env))
587 ((null? (cddr expr))
588 (parse use
589 (cadr expr)
590 env))
591 ((eq? use 'test)
592 (parse use
593 (list 'if
594 (cadr expr)
595 #t
596 (cons 'or (cddr expr)))
597 env))
598 (else
599 (parse use
600 (let ((v (gensym)))
601 (list 'let
602 (list (list v (cadr expr)))
603 (list 'if
604 v
605 v
606 (cons 'or (cddr expr)))))
607 env))))
608 ;; primitive substitution here
609 ;; TODO do this optimization in the following pass instead of at parse time ?
610 ((and (pair? expr)
611 (assoc (car expr) substitute-primitives))
612 =>
613 (lambda (prim)
614 (parse use
615 (cons (cdr prim) (cdr expr))
616 env)))
617 ;; binary arthimetic operations can use primitives directly
618 ((and (pair? expr)
619 (= (length (cdr expr)) 2)
620 (assoc (car expr) '((+ . #%+) (- . #%-) (* . #%*))))
621 =>
622 (lambda (prim)
623 (parse use
624 (cons (cdr prim) (cdr expr))
625 env)))
626 ((and (pair? expr)
627 (memq (car expr)
628 '(quote quasiquote unquote unquote-splicing lambda if
629 set! cond and or case let let* letrec begin do define
630 delay)))
631 (compiler-error "the compiler does not implement the special form" (car expr)))
632 ((pair? expr)
633 (let* ((exprs (map (lambda (x) (parse 'value x env)) expr))
634 (r (make-call #f exprs)))
635 (for-each (lambda (x) (node-parent-set! x r)) exprs)
636 r))
637 (else
638 (compiler-error "unknown expression" expr)))))
640 (define parse-body
641 (lambda (exprs env)
642 (parse 'value (cons 'begin exprs) env)))
644 (define self-eval?
645 (lambda (expr)
646 (or (number? expr)
647 (char? expr)
648 (boolean? expr)
649 (string? expr))))
651 (define extract-ids
652 (lambda (pattern)
653 (if (pair? pattern)
654 (cons (car pattern) (extract-ids (cdr pattern)))
655 (if (symbol? pattern)
656 (cons pattern '())
657 '()))))
659 (define has-rest-param?
660 (lambda (pattern)
661 (if (pair? pattern)
662 (has-rest-param? (cdr pattern))
663 (symbol? pattern))))
665 (define (adjust-unmutable-references! node)
666 '(pretty-print (list unmut: (node->expr node)))
667 (if (and (call? node)
668 '(display "call ")
669 (ref? (car (node-children node)))
670 '(display "ref ")
671 (eq? '#%unbox (var-id (ref-var (car (node-children node)))))
672 '(display "unbox")
673 (ref? (cadr (node-children node)))
674 '(display "ref ")
675 (not (mutable-var? (ref-var (cadr (node-children node)))))
676 '(display "unmut! "))
677 (let* ((parent (node-parent node)) (child (cadr (node-children node))))
678 (node-parent-set! child parent)
679 (if parent
680 (node-children-set! parent
681 (map (lambda (c) (if (eq? c node) child c))
682 (node-children parent))))
683 child)
684 (begin (for-each (lambda (n) (adjust-unmutable-references! n))
685 (node-children node))
686 node)))
688 ;-----------------------------------------------------------------------------
690 ;; Compilation context representation.
692 (define-type context
693 code
694 env
695 env2
696 )
698 (define context-change-code
699 (lambda (ctx code)
700 (make-context code
701 (context-env ctx)
702 (context-env2 ctx))))
704 (define context-change-env
705 (lambda (ctx env)
706 (make-context (context-code ctx)
707 env
708 (context-env2 ctx))))
710 (define context-change-env2
711 (lambda (ctx env2)
712 (make-context (context-code ctx)
713 (context-env ctx)
714 env2)))
716 (define make-init-context
717 (lambda ()
718 (make-context (make-init-code)
719 (make-init-env)
720 #f)))
722 (define context-make-label
723 (lambda (ctx)
724 (context-change-code ctx (code-make-label (context-code ctx)))))
726 (define context-last-label
727 (lambda (ctx)
728 (code-last-label (context-code ctx))))
730 (define context-add-bb
731 (lambda (ctx label)
732 (context-change-code ctx (code-add-bb (context-code ctx) label))))
734 (define context-add-instr
735 (lambda (ctx instr)
736 (context-change-code ctx (code-add-instr (context-code ctx) instr))))
738 ;; Representation of code.
740 (define-type code
741 last-label
742 rev-bbs
743 )
745 (define-type bb
746 label
747 rev-instrs
748 )
750 (define make-init-code
751 (lambda ()
752 (make-code 0
753 (list (make-bb 0 (list))))))
755 (define code-make-label
756 (lambda (code)
757 (let ((label (+ (code-last-label code) 1)))
758 (make-code label
759 (code-rev-bbs code)))))
761 (define code-add-bb
762 (lambda (code label)
763 (make-code
764 (code-last-label code)
765 (cons (make-bb label '())
766 (code-rev-bbs code)))))
768 (define code-add-instr
769 (lambda (code instr)
770 (let* ((rev-bbs (code-rev-bbs code))
771 (bb (car rev-bbs))
772 (rev-instrs (bb-rev-instrs bb)))
773 (make-code
774 (code-last-label code)
775 (cons (make-bb (bb-label bb)
776 (cons instr rev-instrs))
777 (cdr rev-bbs))))))
779 ;; Representation of compile-time stack.
781 (define-type stack
782 size ; number of slots
783 slots ; for each slot, the variable (or #f) contained in the slot
784 )
786 (define make-init-stack
787 (lambda ()
788 (make-stack 0 '())))
790 (define stack-extend
791 (lambda (x nb-slots stk)
792 (let ((size (stack-size stk)))
793 (make-stack
794 (+ size nb-slots)
795 (append (repeat nb-slots x) (stack-slots stk))))))
797 (define stack-discard
798 (lambda (nb-slots stk)
799 (let ((size (stack-size stk)))
800 (make-stack
801 (- size nb-slots)
802 (list-tail (stack-slots stk) nb-slots)))))
804 ;; Representation of compile-time environment.
806 (define-type env
807 local
808 closed
809 )
811 (define make-init-env
812 (lambda ()
813 (make-env (make-init-stack)
814 '())))
816 (define env-change-local
817 (lambda (env local)
818 (make-env local
819 (env-closed env))))
821 (define env-change-closed
822 (lambda (env closed)
823 (make-env (env-local env)
824 closed)))
826 (define find-local-var
827 (lambda (var env)
828 (let ((i (pos-in-list var (stack-slots (env-local env)))))
829 (or i
830 (- (+ (pos-in-list var (env-closed env)) 1))))))
832 (define prc->env
833 (lambda (prc)
834 (make-env
835 (let ((params (prc-params prc)))
836 (make-stack (length params)
837 (append (map var-id params) '())))
838 (let ((vars (varset->list (non-global-fv prc))))
839 ; (pp (map var-id vars))
840 (map var-id vars)))))
842 ;-----------------------------------------------------------------------------
844 (define gen-instruction
845 (lambda (instr nb-pop nb-push ctx)
846 (let* ((env
847 (context-env ctx))
848 (stk
849 (stack-extend #f
850 nb-push
851 (stack-discard nb-pop
852 (env-local env)))))
853 (context-add-instr (context-change-env ctx (env-change-local env stk))
854 instr))))
856 (define gen-entry
857 (lambda (nparams rest? ctx)
858 (gen-instruction (list 'entry nparams rest?) 0 0 ctx)))
860 (define gen-push-constant
861 (lambda (val ctx)
862 (gen-instruction (list 'push-constant val) 0 1 ctx)))
864 (define gen-push-unspecified
865 (lambda (ctx)
866 (gen-push-constant #f ctx)))
868 (define gen-push-local-var
869 (lambda (var ctx)
870 ; (pp (list var: var local: (stack-slots (env-local (context-env ctx))) (env-closed (context-env ctx))))
871 (let ((i (find-local-var var (context-env ctx))))
872 (if (>= i 0)
873 (gen-push-stack i ctx)
874 (gen-push-stack
875 ;; this +1 is needed because closures are in the environment, but
876 ;; don't contain a value, and must therefore be skipped
877 (+ 1
878 (- -1 i)
879 (length (stack-slots (env-local (context-env ctx))))) ctx)))))
881 (define gen-push-stack
882 (lambda (pos ctx)
883 (gen-instruction (list 'push-stack pos) 0 1 ctx)))
885 (define gen-push-global
886 (lambda (var ctx)
887 (gen-instruction (list 'push-global var) 0 1 ctx)))
889 (define gen-set-global
890 (lambda (var ctx)
891 (gen-instruction (list 'set-global var) 1 0 ctx)))
893 (define gen-call
894 (lambda (nargs ctx)
895 (gen-instruction (list 'call nargs) (+ nargs 1) 1 ctx)))
897 (define gen-jump
898 (lambda (nargs ctx)
899 (gen-instruction (list 'jump nargs) (+ nargs 1) 1 ctx)))
901 (define gen-call-toplevel
902 (lambda (nargs id ctx)
903 (gen-instruction (list 'call-toplevel id) nargs 1 ctx)))
905 (define gen-jump-toplevel
906 (lambda (nargs id ctx)
907 (gen-instruction (list 'jump-toplevel id) nargs 1 ctx)))
909 (define gen-goto
910 (lambda (label ctx)
911 (gen-instruction (list 'goto label) 0 0 ctx)))
913 (define gen-goto-if-false
914 (lambda (label-false label-true ctx)
915 (gen-instruction (list 'goto-if-false label-false label-true) 1 0 ctx)))
917 (define gen-closure
918 (lambda (label-entry ctx)
919 (gen-instruction (list 'closure label-entry) 1 1 ctx)))
921 (define gen-prim
922 (lambda (id nargs unspec-result? ctx)
923 (gen-instruction
924 (list 'prim id)
925 nargs
926 (if unspec-result? 0 1)
927 ctx)))
929 (define gen-shift
930 (lambda (n ctx)
931 (if (> n 0)
932 (gen-instruction (list 'shift) 1 0 (gen-shift (- n 1) ctx))
933 ctx)))
935 (define gen-pop
936 (lambda (ctx)
937 (gen-instruction (list 'pop) 1 0 ctx)))
939 (define gen-return
940 (lambda (ctx)
941 (let ((ss (stack-size (env-local (context-env ctx)))))
942 (gen-instruction (list 'return) ss 0 ctx))))
944 ;-----------------------------------------------------------------------------
946 (define child1
947 (lambda (node)
948 (car (node-children node))))
950 (define child2
951 (lambda (node)
952 (cadr (node-children node))))
954 (define child3
955 (lambda (node)
956 (caddr (node-children node))))
958 (define comp-none
959 (lambda (node ctx)
961 (cond ((or (cst? node)
962 (ref? node)
963 (prc? node))
964 ctx)
966 ((def? node)
967 (let ((var (def-var node)))
968 (if (toplevel-prc-with-non-rest-correct-calls? var)
969 (comp-prc (child1 node) #f ctx)
970 (if (var-needed? var)
971 (let ((ctx2 (comp-push (child1 node) ctx)))
972 (gen-set-global (var-id var) ctx2))
973 (comp-none (child1 node) ctx)))))
975 ((set? node)
976 (let ((var (set-var node)))
977 (if (var-needed? var)
978 (let ((ctx2 (comp-push (child1 node) ctx)))
979 (gen-set-global (var-id var) ctx2))
980 (comp-none (child1 node) ctx))))
982 ((if? node)
983 (let* ((ctx2
984 (context-make-label ctx))
985 (label-then
986 (context-last-label ctx2))
987 (ctx3
988 (context-make-label ctx2))
989 (label-else
990 (context-last-label ctx3))
991 (ctx4
992 (context-make-label ctx3))
993 (label-then-join
994 (context-last-label ctx4))
995 (ctx5
996 (context-make-label ctx4))
997 (label-else-join
998 (context-last-label ctx5))
999 (ctx6
1000 (context-make-label ctx5))
1001 (label-join
1002 (context-last-label ctx6))
1003 (ctx7
1004 (comp-test (child1 node) label-then label-else ctx6))
1005 (ctx8
1006 (gen-goto
1007 label-else-join
1008 (comp-none (child3 node)
1009 (context-change-env2
1010 (context-add-bb ctx7 label-else)
1011 #f))))
1012 (ctx9
1013 (gen-goto
1014 label-then-join
1015 (comp-none (child2 node)
1016 (context-change-env
1017 (context-add-bb ctx8 label-then)
1018 (context-env2 ctx7)))))
1019 (ctx10
1020 (gen-goto
1021 label-join
1022 (context-add-bb ctx9 label-else-join)))
1023 (ctx11
1024 (gen-goto
1025 label-join
1026 (context-add-bb ctx10 label-then-join)))
1027 (ctx12
1028 (context-add-bb ctx11 label-join)))
1029 ctx12))
1031 ((call? node)
1032 (comp-call node 'none ctx))
1034 ((seq? node)
1035 (let ((children (node-children node)))
1036 (if (null? children)
1037 ctx
1038 (let loop ((lst children)
1039 (ctx ctx))
1040 (if (null? (cdr lst))
1041 (comp-none (car lst) ctx)
1042 (loop (cdr lst)
1043 (comp-none (car lst) ctx)))))))
1045 (else
1046 (compiler-error "unknown expression type" node)))))
1048 (define comp-tail
1049 (lambda (node ctx)
1051 (cond ((or (cst? node)
1052 (ref? node)
1053 (def? node)
1054 (set? node)
1055 (prc? node)
1056 ; (call? node)
1057 )
1058 (gen-return (comp-push node ctx)))
1060 ((if? node)
1061 (let* ((ctx2
1062 (context-make-label ctx))
1063 (label-then
1064 (context-last-label ctx2))
1065 (ctx3
1066 (context-make-label ctx2))
1067 (label-else
1068 (context-last-label ctx3))
1069 (ctx4
1070 (comp-test (child1 node) label-then label-else ctx3))
1071 (ctx5
1072 (comp-tail (child3 node)
1073 (context-change-env2
1074 (context-add-bb ctx4 label-else)
1075 #f)))
1076 (ctx6
1077 (comp-tail (child2 node)
1078 (context-change-env
1079 (context-add-bb ctx5 label-then)
1080 (context-env2 ctx4)))))
1081 ctx6))
1083 ((call? node)
1084 (comp-call node 'tail ctx))
1086 ((seq? node)
1087 (let ((children (node-children node)))
1088 (if (null? children)
1089 (gen-return (gen-push-unspecified ctx))
1090 (let loop ((lst children)
1091 (ctx ctx))
1092 (if (null? (cdr lst))
1093 (comp-tail (car lst) ctx)
1094 (loop (cdr lst)
1095 (comp-none (car lst) ctx)))))))
1097 (else
1098 (compiler-error "unknown expression type" node)))))
1100 (define comp-push
1101 (lambda (node ctx)
1103 '(
1104 (display "--------------\n")
1105 (pp (node->expr node))
1106 (pp env)
1107 (pp stk)
1108 )
1110 (cond ((cst? node)
1111 (let ((val (cst-val node)))
1112 (gen-push-constant val ctx)))
1114 ((ref? node)
1115 (let ((var (ref-var node)))
1116 (if (var-global? var)
1117 (if (null? (var-defs var))
1118 (compiler-error "undefined variable:" (var-id var))
1119 (let ((val (child1 (car (var-defs var)))))
1120 (if (and (not (mutable-var? var))
1121 (cst? val)) ;; immutable global, counted as cst
1122 (gen-push-constant (cst-val val) ctx)
1123 (gen-push-global (var-id var) ctx))))
1124 (gen-push-local-var (var-id var) ctx))))
1126 ((or (def? node)
1127 (set? node))
1128 (gen-push-unspecified (comp-none node ctx)))
1130 ((if? node)
1131 (let* ((ctx2
1132 (context-make-label ctx))
1133 (label-then
1134 (context-last-label ctx2))
1135 (ctx3
1136 (context-make-label ctx2))
1137 (label-else
1138 (context-last-label ctx3))
1139 (ctx4
1140 (context-make-label ctx3))
1141 (label-then-join
1142 (context-last-label ctx4))
1143 (ctx5
1144 (context-make-label ctx4))
1145 (label-else-join
1146 (context-last-label ctx5))
1147 (ctx6
1148 (context-make-label ctx5))
1149 (label-join
1150 (context-last-label ctx6))
1151 (ctx7
1152 (comp-test (child1 node) label-then label-else ctx6))
1153 (ctx8
1154 (gen-goto
1155 label-else-join
1156 (comp-push (child3 node)
1157 (context-change-env2
1158 (context-add-bb ctx7 label-else)
1159 #f))))
1160 (ctx9
1161 (gen-goto
1162 label-then-join
1163 (comp-push (child2 node)
1164 (context-change-env
1165 (context-add-bb ctx8 label-then)
1166 (context-env2 ctx7)))))
1167 (ctx10
1168 (gen-goto
1169 label-join
1170 (context-add-bb ctx9 label-else-join)))
1171 (ctx11
1172 (gen-goto
1173 label-join
1174 (context-add-bb ctx10 label-then-join)))
1175 (ctx12
1176 (context-add-bb ctx11 label-join)))
1177 ctx12))
1179 ((prc? node)
1180 (comp-prc node #t ctx))
1182 ((call? node)
1183 (comp-call node 'push ctx))
1185 ((seq? node)
1186 (let ((children (node-children node)))
1187 (if (null? children)
1188 (gen-push-unspecified ctx)
1189 (let loop ((lst children)
1190 (ctx ctx))
1191 (if (null? (cdr lst))
1192 (comp-push (car lst) ctx)
1193 (loop (cdr lst)
1194 (comp-none (car lst) ctx)))))))
1196 (else
1197 (compiler-error "unknown expression type" node)))))
1199 (define (build-closure label-entry vars ctx)
1201 (define (build vars ctx)
1202 (if (null? vars)
1203 (gen-push-constant '() ctx)
1204 (gen-prim '#%cons
1205 2
1206 #f
1207 (build (cdr vars)
1208 (gen-push-local-var (car vars) ctx)))))
1210 (if (null? vars)
1211 (gen-closure label-entry
1212 (gen-push-constant '() ctx))
1213 (gen-closure label-entry
1214 (build vars ctx))))
1216 (define comp-prc
1217 (lambda (node closure? ctx)
1218 (let* ((ctx2
1219 (context-make-label ctx))
1220 (label-entry
1221 (context-last-label ctx2))
1222 (ctx3
1223 (context-make-label ctx2))
1224 (label-continue
1225 (context-last-label ctx3))
1226 (body-env
1227 (prc->env node))
1228 (ctx4
1229 (if closure?
1230 (build-closure label-entry (env-closed body-env) ctx3)
1231 ctx3))
1232 (ctx5
1233 (gen-goto label-continue ctx4))
1234 (ctx6
1235 (gen-entry (length (prc-params node))
1236 (prc-rest? node)
1237 (context-add-bb (context-change-env ctx5
1238 body-env)
1239 label-entry)))
1240 (ctx7
1241 (comp-tail (child1 node) ctx6)))
1242 (prc-entry-label-set! node label-entry)
1243 (context-add-bb (context-change-env ctx7 (context-env ctx5))
1244 label-continue))))
1246 (define comp-call
1247 (lambda (node reason ctx)
1248 (let* ((op (child1 node))
1249 (args (cdr (node-children node)))
1250 (nargs (length args)))
1251 (let loop ((lst args)
1252 (ctx ctx))
1253 (if (pair? lst)
1255 (let ((arg (car lst)))
1256 (loop (cdr lst)
1257 (comp-push arg ctx)))
1259 (cond ((and (ref? op)
1260 (var-primitive (ref-var op)))
1261 (let* ((var (ref-var op))
1262 (id (var-id var))
1263 (primitive (var-primitive var))
1264 (prim-nargs (primitive-nargs primitive)))
1266 (define use-result
1267 (lambda (ctx2)
1268 (cond ((eq? reason 'tail)
1269 (gen-return
1270 (if (primitive-unspecified-result? primitive)
1271 (gen-push-unspecified ctx2)
1272 ctx2)))
1273 ((eq? reason 'push)
1274 (if (primitive-unspecified-result? primitive)
1275 (gen-push-unspecified ctx2)
1276 ctx2))
1277 (else
1278 (if (primitive-unspecified-result? primitive)
1279 ctx2
1280 (gen-pop ctx2))))))
1282 (use-result
1283 (if (primitive-inliner primitive)
1284 ((primitive-inliner primitive) ctx)
1285 (if
1286 (not (= nargs prim-nargs))
1287 (compiler-error
1288 "primitive called with wrong number of arguments"
1289 id)
1290 (gen-prim
1291 id
1292 prim-nargs
1293 (primitive-unspecified-result? primitive)
1294 ctx))))))
1297 ((and (ref? op)
1298 (toplevel-prc-with-non-rest-correct-calls?
1299 (ref-var op)))
1300 =>
1301 (lambda (prc)
1302 (cond ((eq? reason 'tail)
1303 (gen-jump-toplevel nargs prc ctx))
1304 ((eq? reason 'push)
1305 (gen-call-toplevel nargs prc ctx))
1306 (else
1307 (gen-pop (gen-call-toplevel nargs prc ctx))))))
1309 (else
1310 (let ((ctx2 (comp-push op ctx)))
1311 (cond ((eq? reason 'tail)
1312 (gen-jump nargs ctx2))
1313 ((eq? reason 'push)
1314 (gen-call nargs ctx2))
1315 (else
1316 (gen-pop (gen-call nargs ctx2))))))))))))
1318 (define comp-test
1319 (lambda (node label-true label-false ctx)
1320 (cond ((cst? node)
1321 (let ((ctx2
1322 (gen-goto
1323 (let ((val (cst-val node)))
1324 (if val
1325 label-true
1326 label-false))
1327 ctx)))
1328 (context-change-env2 ctx2 (context-env ctx2))))
1330 ((or (ref? node)
1331 (def? node)
1332 (set? node)
1333 (if? node)
1334 (call? node)
1335 (seq? node))
1336 (let* ((ctx2
1337 (comp-push node ctx))
1338 (ctx3
1339 (gen-goto-if-false label-false label-true ctx2)))
1340 (context-change-env2 ctx3 (context-env ctx3))))
1342 ((prc? node)
1343 (let ((ctx2
1344 (gen-goto label-true ctx)))
1345 (context-change-env2 ctx2 (context-env ctx2))))
1347 (else
1348 (compiler-error "unknown expression type" node)))))
1350 ;-----------------------------------------------------------------------------
1352 (define toplevel-prc?
1353 (lambda (var)
1354 (and (not (mutable-var? var))
1355 (let ((d (var-defs var)))
1356 (and (pair? d)
1357 (null? (cdr d))
1358 (let ((val (child1 (car d))))
1359 (and (prc? val)
1360 val)))))))
1362 (define toplevel-prc-with-non-rest-correct-calls?
1363 (lambda (var)
1364 (let ((prc (toplevel-prc? var)))
1365 (and prc
1366 (not (prc-rest? prc))
1367 (every (lambda (r)
1368 (let ((parent (node-parent r)))
1369 (and (call? parent)
1370 (eq? (child1 parent) r)
1371 (= (length (prc-params prc))
1372 (- (length (node-children parent)) 1)))))
1373 (var-refs var))
1374 prc))))
1376 (define mutable-var?
1377 (lambda (var)
1378 (not (null? (var-sets var)))))
1380 (define global-fv
1381 (lambda (node)
1382 (list->varset
1383 (keep var-global?
1384 (varset->list (fv node))))))
1386 (define non-global-fv
1387 (lambda (node)
1388 (list->varset
1389 (keep (lambda (x) (not (var-global? x)))
1390 (varset->list (fv node))))))
1392 (define fv
1393 (lambda (node)
1394 (cond ((cst? node)
1395 (varset-empty))
1396 ((ref? node)
1397 (let ((var (ref-var node)))
1398 (varset-singleton var)))
1399 ((def? node)
1400 (let ((var (def-var node))
1401 (val (child1 node)))
1402 (varset-union
1403 (varset-singleton var)
1404 (fv val))))
1405 ((set? node)
1406 (let ((var (set-var node))
1407 (val (child1 node)))
1408 (varset-union
1409 (varset-singleton var)
1410 (fv val))))
1411 ((if? node)
1412 (let ((a (list-ref (node-children node) 0))
1413 (b (list-ref (node-children node) 1))
1414 (c (list-ref (node-children node) 2)))
1415 (varset-union-multi (list (fv a) (fv b) (fv c)))))
1416 ((prc? node)
1417 (let ((body (list-ref (node-children node) 0)))
1418 (varset-difference
1419 (fv body)
1420 (build-params-varset (prc-params node)))))
1421 ((call? node)
1422 (varset-union-multi (map fv (node-children node))))
1423 ((seq? node)
1424 (varset-union-multi (map fv (node-children node))))
1425 (else
1426 (compiler-error "unknown expression type" node)))))
1428 (define build-params-varset
1429 (lambda (params)
1430 (list->varset params)))
1432 (define mark-needed-global-vars!
1433 (lambda (global-env node)
1435 (define readyq
1436 (env-lookup global-env '#%readyq))
1438 (define mark-var!
1439 (lambda (var)
1440 (if (and (var-global? var)
1441 (not (var-needed? var))
1442 ;; globals that obey the following conditions are considered
1443 ;; to be constants
1444 (not (and (not (mutable-var? var))
1445 ;; to weed out primitives, which have no definitions
1446 (> (length (var-defs var)) 0)
1447 (cst? (child1 (car (var-defs var)))))))
1448 (begin
1449 (var-needed?-set! var #t)
1450 (for-each
1451 (lambda (def)
1452 (let ((val (child1 def)))
1453 (if (side-effect-less? val)
1454 (mark! val))))
1455 (var-defs var))
1456 (if (eq? var readyq)
1457 (begin
1458 (mark-var!
1459 (env-lookup global-env '#%start-first-process))
1460 (mark-var!
1461 (env-lookup global-env '#%exit))))))))
1463 (define side-effect-less?
1464 (lambda (node)
1465 (or (cst? node)
1466 (ref? node)
1467 (prc? node))))
1469 (define mark!
1470 (lambda (node)
1471 (cond ((cst? node))
1472 ((ref? node)
1473 (let ((var (ref-var node)))
1474 (mark-var! var)))
1475 ((def? node)
1476 (let ((var (def-var node))
1477 (val (child1 node)))
1478 (if (not (side-effect-less? val))
1479 (mark! val))))
1480 ((set? node)
1481 (let ((var (set-var node))
1482 (val (child1 node)))
1483 (mark! val)))
1484 ((if? node)
1485 (let ((a (list-ref (node-children node) 0))
1486 (b (list-ref (node-children node) 1))
1487 (c (list-ref (node-children node) 2)))
1488 (mark! a)
1489 (mark! b)
1490 (mark! c)))
1491 ((prc? node)
1492 (let ((body (list-ref (node-children node) 0)))
1493 (mark! body)))
1494 ((call? node)
1495 (for-each mark! (node-children node)))
1496 ((seq? node)
1497 (for-each mark! (node-children node)))
1498 (else
1499 (compiler-error "unknown expression type" node)))))
1501 (mark! node)
1502 ))
1504 ;-----------------------------------------------------------------------------
1506 ;; Variable sets
1508 (define (varset-empty) ; return the empty set
1509 '())
1511 (define (varset-singleton x) ; create a set containing only 'x'
1512 (list x))
1514 (define (list->varset lst) ; convert list to set
1515 lst)
1517 (define (varset->list set) ; convert set to list
1518 set)
1520 (define (varset-size set) ; return cardinality of set
1521 (list-length set))
1523 (define (varset-empty? set) ; is 'x' the empty set?
1524 (null? set))
1526 (define (varset-member? x set) ; is 'x' a member of the 'set'?
1527 (and (not (null? set))
1528 (or (eq? x (car set))
1529 (varset-member? x (cdr set)))))
1531 (define (varset-adjoin set x) ; add the element 'x' to the 'set'
1532 (if (varset-member? x set) set (cons x set)))
1534 (define (varset-remove set x) ; remove the element 'x' from 'set'
1535 (cond ((null? set)
1536 '())
1537 ((eq? (car set) x)
1538 (cdr set))
1539 (else
1540 (cons (car set) (varset-remove (cdr set) x)))))
1542 (define (varset-equal? s1 s2) ; are 's1' and 's2' equal sets?
1543 (and (varset-subset? s1 s2)
1544 (varset-subset? s2 s1)))
1546 (define (varset-subset? s1 s2) ; is 's1' a subset of 's2'?
1547 (cond ((null? s1)
1548 #t)
1549 ((varset-member? (car s1) s2)
1550 (varset-subset? (cdr s1) s2))
1551 (else
1552 #f)))
1554 (define (varset-difference set1 set2) ; return difference of sets
1555 (cond ((null? set1)
1556 '())
1557 ((varset-member? (car set1) set2)
1558 (varset-difference (cdr set1) set2))
1559 (else
1560 (cons (car set1) (varset-difference (cdr set1) set2)))))
1562 (define (varset-union set1 set2) ; return union of sets
1563 (define (union s1 s2)
1564 (cond ((null? s1)
1565 s2)
1566 ((varset-member? (car s1) s2)
1567 (union (cdr s1) s2))
1568 (else
1569 (cons (car s1) (union (cdr s1) s2)))))
1570 (if (varset-smaller? set1 set2)
1571 (union set1 set2)
1572 (union set2 set1)))
1574 (define (varset-intersection set1 set2) ; return intersection of sets
1575 (define (intersection s1 s2)
1576 (cond ((null? s1)
1577 '())
1578 ((varset-member? (car s1) s2)
1579 (cons (car s1) (intersection (cdr s1) s2)))
1580 (else
1581 (intersection (cdr s1) s2))))
1582 (if (varset-smaller? set1 set2)
1583 (intersection set1 set2)
1584 (intersection set2 set1)))
1586 (define (varset-intersects? set1 set2) ; do sets 'set1' and 'set2' intersect?
1587 (not (varset-empty? (varset-intersection set1 set2))))
1589 (define (varset-smaller? set1 set2)
1590 (if (null? set1)
1591 (not (null? set2))
1592 (if (null? set2)
1593 #f
1594 (varset-smaller? (cdr set1) (cdr set2)))))
1596 (define (varset-union-multi sets)
1597 (if (null? sets)
1598 (varset-empty)
1599 (n-ary varset-union (car sets) (cdr sets))))
1601 (define (n-ary function first rest)
1602 (if (null? rest)
1603 first
1604 (n-ary function (function first (car rest)) (cdr rest))))
1606 ;------------------------------------------------------------------------------
1608 (define code->vector
1609 (lambda (code)
1610 (let ((v (make-vector (+ (code-last-label code) 1))))
1611 (for-each
1612 (lambda (bb)
1613 (vector-set! v (bb-label bb) bb))
1614 (code-rev-bbs code))
1615 v)))
1617 (define bbs->ref-counts
1618 (lambda (bbs)
1619 (let ((ref-counts (make-vector (vector-length bbs) 0)))
1621 (define visit
1622 (lambda (label)
1623 (let ((ref-count (vector-ref ref-counts label)))
1624 (vector-set! ref-counts label (+ ref-count 1))
1625 (if (= ref-count 0)
1626 (let* ((bb (vector-ref bbs label))
1627 (rev-instrs (bb-rev-instrs bb)))
1628 (for-each
1629 (lambda (instr)
1630 (let ((opcode (car instr)))
1631 (cond ((eq? opcode 'goto)
1632 (visit (cadr instr)))
1633 ((eq? opcode 'goto-if-false)
1634 (visit (cadr instr))
1635 (visit (caddr instr)))
1636 ((or (eq? opcode 'closure)
1637 (eq? opcode 'call-toplevel)
1638 (eq? opcode 'jump-toplevel))
1639 (visit (cadr instr))))))
1640 rev-instrs))))))
1642 (visit 0)
1644 ref-counts)))
1646 (define resolve-toplevel-labels!
1647 (lambda (bbs)
1648 (let loop ((i 0))
1649 (if (< i (vector-length bbs))
1650 (let* ((bb (vector-ref bbs i))
1651 (rev-instrs (bb-rev-instrs bb)))
1652 (bb-rev-instrs-set!
1653 bb
1654 (map (lambda (instr)
1655 (let ((opcode (car instr)))
1656 (cond ((eq? opcode 'call-toplevel)
1657 (list opcode
1658 (prc-entry-label (cadr instr))))
1659 ((eq? opcode 'jump-toplevel)
1660 (list opcode
1661 (prc-entry-label (cadr instr))))
1662 (else
1663 instr))))
1664 rev-instrs))
1665 (loop (+ i 1)))))))
1667 (define tighten-jump-cascades!
1668 (lambda (bbs)
1669 (let ((ref-counts (bbs->ref-counts bbs)))
1671 (define resolve
1672 (lambda (label)
1673 (let* ((bb (vector-ref bbs label))
1674 (rev-instrs (bb-rev-instrs bb)))
1675 (and (or (null? (cdr rev-instrs))
1676 (= (vector-ref ref-counts label) 1))
1677 rev-instrs))))
1679 (let loop1 ()
1680 (let loop2 ((i 0)
1681 (changed? #f))
1682 (if (< i (vector-length bbs))
1683 (if (> (vector-ref ref-counts i) 0)
1684 (let* ((bb (vector-ref bbs i))
1685 (rev-instrs (bb-rev-instrs bb))
1686 (jump (car rev-instrs))
1687 (opcode (car jump)))
1688 (cond ((eq? opcode 'goto)
1689 (let* ((label (cadr jump))
1690 (jump-replacement (resolve label)))
1691 (if jump-replacement
1692 (begin
1693 (vector-set!
1694 bbs
1695 i
1696 (make-bb (bb-label bb)
1697 (append jump-replacement
1698 (cdr rev-instrs))))
1699 (loop2 (+ i 1)
1700 #t))
1701 (loop2 (+ i 1)
1702 changed?))))
1703 ((eq? opcode 'goto-if-false)
1704 (let* ((label-then (cadr jump))
1705 (label-else (caddr jump))
1706 (jump-then-replacement (resolve label-then))
1707 (jump-else-replacement (resolve label-else)))
1708 (if (and jump-then-replacement
1709 (null? (cdr jump-then-replacement))
1710 jump-else-replacement
1711 (null? (cdr jump-else-replacement))
1712 (or (eq? (caar jump-then-replacement)
1713 'goto)
1714 (eq? (caar jump-else-replacement)
1715 'goto)))
1716 (begin
1717 (vector-set!
1718 bbs
1719 i
1720 (make-bb
1721 (bb-label bb)
1722 (cons
1723 (list
1724 'goto-if-false
1725 (if (eq? (caar jump-then-replacement)
1726 'goto)
1727 (cadar jump-then-replacement)
1728 label-then)
1729 (if (eq? (caar jump-else-replacement)
1730 'goto)
1731 (cadar jump-else-replacement)
1732 label-else))
1733 (cdr rev-instrs))))
1734 (loop2 (+ i 1)
1735 #t))
1736 (loop2 (+ i 1)
1737 changed?))))
1738 (else
1739 (loop2 (+ i 1)
1740 changed?))))
1741 (loop2 (+ i 1)
1742 changed?))
1743 (if changed?
1744 (loop1))))))))
1746 (define remove-useless-bbs!
1747 (lambda (bbs)
1748 (let ((ref-counts (bbs->ref-counts bbs)))
1749 (let loop1 ((label 0) (new-label 0))
1750 (if (< label (vector-length bbs))
1751 (if (> (vector-ref ref-counts label) 0)
1752 (let ((bb (vector-ref bbs label)))
1753 (vector-set!
1754 bbs
1755 label
1756 (make-bb new-label (bb-rev-instrs bb)))
1757 (loop1 (+ label 1) (+ new-label 1)))
1758 (loop1 (+ label 1) new-label))
1759 (renumber-labels bbs ref-counts new-label))))))
1761 (define renumber-labels
1762 (lambda (bbs ref-counts n)
1763 (let ((new-bbs (make-vector n)))
1764 (let loop2 ((label 0))
1765 (if (< label (vector-length bbs))
1766 (if (> (vector-ref ref-counts label) 0)
1767 (let* ((bb (vector-ref bbs label))
1768 (new-label (bb-label bb))
1769 (rev-instrs (bb-rev-instrs bb)))
1771 (define fix
1772 (lambda (instr)
1774 (define new-label
1775 (lambda (label)
1776 (bb-label (vector-ref bbs label))))
1778 (let ((opcode (car instr)))
1779 (cond ((eq? opcode 'closure)
1780 (list 'closure
1781 (new-label (cadr instr))))
1782 ((eq? opcode 'call-toplevel)
1783 (list 'call-toplevel
1784 (new-label (cadr instr))))
1785 ((eq? opcode 'jump-toplevel)
1786 (list 'jump-toplevel
1787 (new-label (cadr instr))))
1788 ((eq? opcode 'goto)
1789 (list 'goto
1790 (new-label (cadr instr))))
1791 ((eq? opcode 'goto-if-false)
1792 (list 'goto-if-false
1793 (new-label (cadr instr))
1794 (new-label (caddr instr))))
1795 (else
1796 instr)))))
1798 (vector-set!
1799 new-bbs
1800 new-label
1801 (make-bb new-label (map fix rev-instrs)))
1802 (loop2 (+ label 1)))
1803 (loop2 (+ label 1)))
1804 new-bbs)))))
1806 (define reorder!
1807 (lambda (bbs)
1808 (let* ((done (make-vector (vector-length bbs) #f)))
1810 (define unscheduled?
1811 (lambda (label)
1812 (not (vector-ref done label))))
1814 (define label-refs
1815 (lambda (instrs todo)
1816 (if (pair? instrs)
1817 (let* ((instr (car instrs))
1818 (opcode (car instr)))
1819 (cond ((or (eq? opcode 'closure)
1820 (eq? opcode 'call-toplevel)
1821 (eq? opcode 'jump-toplevel))
1822 (label-refs (cdr instrs) (cons (cadr instr) todo)))
1823 (else
1824 (label-refs (cdr instrs) todo))))
1825 todo)))
1827 (define schedule-here
1828 (lambda (label new-label todo cont)
1829 (let* ((bb (vector-ref bbs label))
1830 (rev-instrs (bb-rev-instrs bb))
1831 (jump (car rev-instrs))
1832 (opcode (car jump))
1833 (new-todo (label-refs rev-instrs todo)))
1834 (vector-set! bbs label (make-bb new-label rev-instrs))
1835 (vector-set! done label #t)
1836 (cond ((eq? opcode 'goto)
1837 (let ((label (cadr jump)))
1838 (if (unscheduled? label)
1839 (schedule-here label
1840 (+ new-label 1)
1841 new-todo
1842 cont)
1843 (cont (+ new-label 1)
1844 new-todo))))
1845 ((eq? opcode 'goto-if-false)
1846 (let ((label-then (cadr jump))
1847 (label-else (caddr jump)))
1848 (cond ((unscheduled? label-else)
1849 (schedule-here label-else
1850 (+ new-label 1)
1851 (cons label-then new-todo)
1852 cont))
1853 ((unscheduled? label-then)
1854 (schedule-here label-then
1855 (+ new-label 1)
1856 new-todo
1857 cont))
1858 (else
1859 (cont (+ new-label 1)
1860 new-todo)))))
1861 (else
1862 (cont (+ new-label 1)
1863 new-todo))))))
1865 (define schedule-somewhere
1866 (lambda (label new-label todo cont)
1867 (schedule-here label new-label todo cont)))
1869 (define schedule-todo
1870 (lambda (new-label todo)
1871 (if (pair? todo)
1872 (let ((label (car todo)))
1873 (if (unscheduled? label)
1874 (schedule-somewhere label
1875 new-label
1876 (cdr todo)
1877 schedule-todo)
1878 (schedule-todo new-label
1879 (cdr todo)))))))
1882 (schedule-here 0 0 '() schedule-todo)
1884 (renumber-labels bbs
1885 (make-vector (vector-length bbs) 1)
1886 (vector-length bbs)))))
1888 (define linearize
1889 (lambda (bbs)
1890 (let loop ((label (- (vector-length bbs) 1))
1891 (lst '()))
1892 (if (>= label 0)
1893 (let* ((bb (vector-ref bbs label))
1894 (rev-instrs (bb-rev-instrs bb))
1895 (jump (car rev-instrs))
1896 (opcode (car jump)))
1897 (loop (- label 1)
1898 (append
1899 (list label)
1900 (reverse
1901 (cond ((eq? opcode 'goto)
1902 (if (= (cadr jump) (+ label 1))
1903 (cdr rev-instrs)
1904 rev-instrs))
1905 ((eq? opcode 'goto-if-false)
1906 (cond ((= (caddr jump) (+ label 1))
1907 (cons (list 'goto-if-false (cadr jump))
1908 (cdr rev-instrs)))
1909 ((= (cadr jump) (+ label 1))
1910 (cons (list 'goto-if-not-false (caddr jump))
1911 (cdr rev-instrs)))
1912 (else
1913 (cons (list 'goto (caddr jump))
1914 (cons (list 'goto-if-false (cadr jump))
1915 (cdr rev-instrs))))))
1916 (else
1917 rev-instrs)))
1918 lst)))
1919 lst))))
1921 (define optimize-code
1922 (lambda (code)
1923 (let ((bbs (code->vector code)))
1924 (resolve-toplevel-labels! bbs)
1925 (tighten-jump-cascades! bbs)
1926 (let ((bbs (remove-useless-bbs! bbs)))
1927 (reorder! bbs)))))
1930 (define expand-includes
1931 (lambda (exprs)
1932 (map (lambda (e)
1933 (if (eq? (car e) 'include)
1934 (cons 'begin
1935 (expand-includes
1936 (with-input-from-file (cadr e) read-all)))
1937 e))
1938 exprs)))
1940 (define parse-file
1941 (lambda (filename)
1942 (let* ((library ;; TODO do not hard-code path
1943 (with-input-from-file "library.scm" read-all))
1944 (toplevel-exprs
1945 (expand-includes
1946 (append library
1947 (with-input-from-file filename read-all))))
1948 (global-env
1949 (make-global-env))
1950 (parsed-prog
1951 (parse-top (cons 'begin toplevel-exprs) global-env)))
1953 (for-each
1954 (lambda (node)
1955 (mark-needed-global-vars! global-env node))
1956 parsed-prog)
1958 (extract-parts
1959 parsed-prog
1960 (lambda (defs after-defs)
1962 (define make-seq-preparsed
1963 (lambda (exprs)
1964 (let ((r (make-seq #f exprs)))
1965 (for-each (lambda (x) (node-parent-set! x r)) exprs)
1966 r)))
1968 (define make-call-preparsed
1969 (lambda (exprs)
1970 (let ((r (make-call #f exprs)))
1971 (for-each (lambda (x) (node-parent-set! x r)) exprs)
1972 r)))
1974 (if (var-needed?
1975 (env-lookup global-env '#%readyq))
1976 (make-seq-preparsed
1977 (list (make-seq-preparsed defs)
1978 (make-call-preparsed
1979 (list (parse 'value '#%start-first-process global-env)
1980 (let* ((pattern
1981 '())
1982 (ids
1983 (extract-ids pattern))
1984 (r
1985 (make-prc #f
1986 '()
1987 #f
1988 (has-rest-param? pattern)
1989 #f))
1990 (new-env
1991 (env-extend global-env ids r))
1992 (body
1993 (make-seq-preparsed after-defs)))
1994 (prc-params-set!
1995 r
1996 (map (lambda (id) (env-lookup new-env id))
1997 ids))
1998 (node-children-set! r (list body))
1999 (node-parent-set! body r)
2000 r)))
2001 (parse 'value
2002 '(#%exit)
2003 global-env)))
2004 (make-seq-preparsed
2005 (append defs
2006 after-defs
2007 (list (parse 'value
2008 '(#%halt)
2009 global-env))))))))))
2011 (define extract-parts
2012 (lambda (lst cont)
2013 (if (or (null? lst)
2014 (not (def? (car lst))))
2015 (cont '() lst)
2016 (extract-parts
2017 (cdr lst)
2018 (lambda (d ad)
2019 (cont (cons (car lst) d) ad))))))
2021 ;------------------------------------------------------------------------------
2023 ;;(include "asm.scm")
2025 ;;; File: "asm.scm"
2026 ;;;
2027 ;;; This module implements the generic assembler.
2029 ;;(##declare (standard-bindings) (fixnum) (block))
2031 (define compiler-internal-error error)
2033 ;; (asm-begin! start-pos big-endian?) initializes the assembler and
2034 ;; starts a new empty code stream at address "start-pos". It must be
2035 ;; called every time a new code stream is to be built. The argument
2036 ;; "big-endian?" indicates the byte ordering to use for 16, 32 and 64
2037 ;; bit values. After a call to "asm-begin!" the code stream is built
2038 ;; by calling the following procedures:
2039 ;;
2040 ;; asm-8 to add an 8 bit integer to the code stream
2041 ;; asm-16 to add a 16 bit integer to the code stream
2042 ;; asm-32 to add a 32 bit integer to the code stream
2043 ;; asm-64 to add a 64 bit integer to the code stream
2044 ;; asm-float64 to add a 64 bit IEEE float to the code stream
2045 ;; asm-string to add a null terminated string to the code stream
2046 ;; asm-label to set a label to the current position in the code stream
2047 ;; asm-align to add enough zero bytes to force alignment
2048 ;; asm-origin to add enough zero bytes to move to a particular address
2049 ;; asm-at-assembly to defer code production to assembly time
2050 ;; asm-listing to add textual information to the listing
2052 (define (asm-begin! start-pos big-endian?)
2053 (set! asm-start-pos start-pos)
2054 (set! asm-big-endian? big-endian?)
2055 (set! asm-code-stream (asm-make-stream))
2056 #f)
2058 ;; (asm-end!) must be called to finalize the assembler.
2060 (define (asm-end!)
2061 (set! asm-code-stream #f)
2062 #f)
2064 ;; (asm-8 n) adds an 8 bit signed or unsigned integer to the code stream.
2066 (define (asm-8 n)
2067 (asm-code-extend (asm-bits-0-to-7 n)))
2069 ;; (asm-16 n) adds a 16 bit signed or unsigned integer to the code stream.
2071 (define (asm-16 n)
2072 (if asm-big-endian?
2073 (begin (asm-8 (asm-bits-8-and-up n)) (asm-8 n))
2074 (begin (asm-8 n) (asm-8 (asm-bits-8-and-up n)))))
2076 ;; (asm-32 n) adds a 32 bit signed or unsigned integer to the code stream.
2078 (define (asm-32 n)
2079 (if asm-big-endian?
2080 (begin (asm-16 (asm-bits-16-and-up n)) (asm-16 n))
2081 (begin (asm-16 n) (asm-16 (asm-bits-16-and-up n)))))
2083 ;; (asm-64 n) adds a 64 bit signed or unsigned integer to the code stream.
2085 (define (asm-64 n)
2086 (if asm-big-endian?
2087 (begin (asm-32 (asm-bits-32-and-up n)) (asm-32 n))
2088 (begin (asm-32 n) (asm-32 (asm-bits-32-and-up n)))))
2090 ;; (asm-float64 n) adds a 64 bit IEEE floating point number to the code stream.
2092 (define (asm-float64 n)
2093 (asm-64 (asm-float->bits n)))
2095 ;; (asm-string str) adds a null terminated string to the code stream.
2097 (define (asm-string str)
2098 (let ((len (string-length str)))
2099 (let loop ((i 0))
2100 (if (< i len)
2101 (begin
2102 (asm-8 (char->integer (string-ref str i)))
2103 (loop (+ i 1)))
2104 (asm-8 0)))))
2106 ;; (asm-make-label id) creates a new label object. A label can
2107 ;; be queried with "asm-label-pos" to obtain the label's position
2108 ;; relative to the start of the code stream (i.e. "start-pos").
2109 ;; The argument "id" gives a name to the label (not necessarily
2110 ;; unique) and is only needed for debugging purposes.
2112 (define (asm-make-label id)
2113 (vector 'LABEL #f id))
2115 ;; (asm-label label-obj) sets the label to the current position in the
2116 ;; code stream.
2118 (define (asm-label label-obj)
2119 (if (vector-ref label-obj 1)
2120 (compiler-internal-error
2121 "asm-label, label multiply defined" (asm-label-id label-obj))
2122 (begin
2123 (vector-set! label-obj 1 0)
2124 (asm-code-extend label-obj))))
2126 ;; (asm-label-id label-obj) returns the identifier of the label object.
2128 (define (asm-label-id label-obj)
2129 (vector-ref label-obj 2))
2131 ;; (asm-label-pos label-obj) returns the position of the label
2132 ;; relative to the start of the code stream (i.e. "start-pos").
2133 ;; This procedure can only be called at assembly time (i.e.
2134 ;; within the call to "asm-assemble") or after assembly time
2135 ;; for labels declared prior to assembly time with "asm-label".
2136 ;; A label declared at assembly time can only be queried after
2137 ;; assembly time. Moreover, at assembly time the position of a
2138 ;; label may vary from one call to the next due to the actions
2139 ;; of the assembler.
2141 (define (asm-label-pos label-obj)
2142 (let ((pos (vector-ref label-obj 1)))
2143 (if pos
2144 pos
2145 (compiler-internal-error
2146 "asm-label-pos, undefined label" (asm-label-id label-obj)))))
2148 ;; (asm-align multiple offset) adds enough zero bytes to the code
2149 ;; stream to force alignment to the next address congruent to
2150 ;; "offset" modulo "multiple".
2152 (define (asm-align multiple offset)
2153 (asm-at-assembly
2154 (lambda (self)
2155 (modulo (- multiple (- self offset)) multiple))
2156 (lambda (self)
2157 (let loop ((n (modulo (- multiple (- self offset)) multiple)))
2158 (if (> n 0)
2159 (begin
2160 (asm-8 0)
2161 (loop (- n 1))))))))
2163 ;; (asm-origin address) adds enough zero bytes to the code stream to move
2164 ;; to the address "address".
2166 (define (asm-origin address)
2167 (asm-at-assembly
2168 (lambda (self)
2169 (- address self))
2170 (lambda (self)
2171 (let ((len (- address self)))
2172 (if (< len 0)
2173 (compiler-internal-error "asm-origin, can't move back")
2174 (let loop ((n len))
2175 (if (> n 0)
2176 (begin
2177 (asm-8 0)
2178 (loop (- n 1))))))))))
2180 ;; (asm-at-assembly . procs) makes it possible to defer code
2181 ;; production to assembly time. A useful application is to generate
2182 ;; position dependent and span dependent code sequences. This
2183 ;; procedure must be passed an even number of procedures. All odd
2184 ;; indexed procedures (including the first procedure) are called "check"
2185 ;; procedures. The even indexed procedures are the "production"
2186 ;; procedures which, when called, produce a particular code sequence.
2187 ;; A check procedure decides if, given the current state of assembly
2188 ;; (in particular the current positioning of the labels), the code
2189 ;; produced by the corresponding production procedure is valid.
2190 ;; If the code is not valid, the check procedure must return #f.
2191 ;; If the code is valid, the check procedure must return the length
2192 ;; of the code sequence in bytes. The assembler will try each check
2193 ;; procedure in order until it finds one that does not return #f
2194 ;; (the last check procedure must never return #f). For convenience,
2195 ;; the current position in the code sequence is passed as the single
2196 ;; argument of check and production procedures.
2197 ;;
2198 ;; Here is a sample call of "asm-at-assembly" to produce the
2199 ;; shortest branch instruction to branch to label "x" for a
2200 ;; hypothetical processor:
2201 ;;
2202 ;; (asm-at-assembly
2203 ;;
2204 ;; (lambda (self) ; first check procedure
2205 ;; (let ((dist (- (asm-label-pos x) self)))
2206 ;; (if (and (>= dist -128) (<= dist 127)) ; short branch possible?
2207 ;; 2
2208 ;; #f)))
2209 ;;
2210 ;; (lambda (self) ; first production procedure
2211 ;; (asm-8 #x34) ; branch opcode for 8 bit displacement
2212 ;; (asm-8 (- (asm-label-pos x) self)))
2213 ;;
2214 ;; (lambda (self) 5) ; second check procedure
2215 ;;
2216 ;; (lambda (self) ; second production procedure
2217 ;; (asm-8 #x35) ; branch opcode for 32 bit displacement
2218 ;; (asm-32 (- (asm-label-pos x) self))))
2220 (define (asm-at-assembly . procs)
2221 (asm-code-extend (vector 'DEFERRED procs)))
2223 ;; (asm-listing text) adds text to the right side of the listing.
2224 ;; The atoms in "text" will be output using "display" (lists are
2225 ;; traversed recursively). The listing is generated by calling
2226 ;; "asm-display-listing".
2228 (define (asm-listing text)
2229 (asm-code-extend (vector 'LISTING text)))
2231 ;; (asm-assemble) assembles the code stream. After assembly, the
2232 ;; label objects will be set to their final position and the
2233 ;; alignment bytes and the deferred code will have been produced. It
2234 ;; is possible to extend the code stream after assembly. However, if
2235 ;; any of the procedures "asm-label", "asm-align", and
2236 ;; "asm-at-assembly" are called, the code stream will have to be
2237 ;; assembled once more.
2239 (define (asm-assemble)
2240 (let ((fixup-lst (asm-pass1)))
2242 (let loop1 ()
2243 (let loop2 ((lst fixup-lst)
2244 (changed? #f)
2245 (pos asm-start-pos))
2246 (if (null? lst)
2247 (if changed? (loop1))
2248 (let* ((fixup (car lst))
2249 (pos (+ pos (car fixup)))
2250 (curr (cdr fixup))
2251 (x (car curr)))
2252 (if (eq? (vector-ref x 0) 'LABEL)
2253 ; LABEL
2254 (if (= (vector-ref x 1) pos)
2255 (loop2 (cdr lst) changed? pos)
2256 (begin
2257 (vector-set! x 1 pos)
2258 (loop2 (cdr lst) #t pos)))
2259 ; DEFERRED
2260 (let loop3 ()
2261 (let ((n ((car (vector-ref x 1)) pos)))
2262 (if n
2263 (loop2 (cdr lst) changed? (+ pos n))
2264 (begin
2265 (vector-set! x 1 (cddr (vector-ref x 1)))
2266 (loop3))))))))))
2268 (let loop4 ((prev asm-code-stream)
2269 (curr (cdr asm-code-stream))
2270 (pos asm-start-pos))
2271 (if (null? curr)
2272 (set-car! asm-code-stream prev)
2273 (let ((x (car curr))
2274 (next (cdr curr)))
2275 (if (vector? x)
2276 (let ((kind (vector-ref x 0)))
2277 (cond ((eq? kind 'LABEL)
2278 (let ((final-pos (vector-ref x 1)))
2279 (if final-pos
2280 (if (not (= pos final-pos))
2281 (compiler-internal-error
2282 "asm-assemble, inconsistency detected"))
2283 (vector-set! x 1 pos))
2284 (set-cdr! prev next)
2285 (loop4 prev next pos)))
2286 ((eq? kind 'DEFERRED)
2287 (let ((temp asm-code-stream))
2288 (set! asm-code-stream (asm-make-stream))
2289 ((cadr (vector-ref x 1)) pos)
2290 (let ((tail (car asm-code-stream)))
2291 (set-cdr! tail next)
2292 (let ((head (cdr asm-code-stream)))
2293 (set-cdr! prev head)
2294 (set! asm-code-stream temp)
2295 (loop4 prev head pos)))))
2296 (else
2297 (loop4 curr next pos))))
2298 (loop4 curr next (+ pos 1))))))))
2300 ;; (asm-display-listing port) produces a listing of the code stream
2301 ;; on the given output port. The bytes generated are shown in
2302 ;; hexadecimal on the left side of the listing and the right side
2303 ;; of the listing contains the text inserted by "asm-listing".
2305 (define (asm-display-listing port)
2307 (define text-col 24)
2308 (define pos-width 6)
2309 (define byte-width 2)
2311 (define (output text)
2312 (cond ((null? text))
2313 ((pair? text)
2314 (output (car text))
2315 (output (cdr text)))
2316 (else
2317 (display text port))))
2319 (define (print-hex n)
2320 (display (string-ref "0123456789ABCDEF" n) port))
2322 (define (print-byte n)
2323 (print-hex (quotient n 16))
2324 (print-hex (modulo n 16)))
2326 (define (print-pos n)
2327 (if (< n 0)
2328 (display " " port)
2329 (begin
2330 (print-byte (quotient n #x10000))
2331 (print-byte (modulo (quotient n #x100) #x100))
2332 (print-byte (modulo n #x100)))))
2334 (let loop1 ((lst (cdr asm-code-stream)) (pos asm-start-pos) (col 0))
2335 (if (null? lst)
2336 (if (> col 0)
2337 (newline port))
2338 (let ((x (car lst)))
2339 (if (vector? x)
2340 (let ((kind (vector-ref x 0)))
2341 (cond ((eq? kind 'LISTING)
2342 (let loop2 ((col col))
2343 (if (< col text-col)
2344 (begin
2345 (display (integer->char 9) port)
2346 (loop2 (* 8 (+ (quotient col 8) 1))))))
2347 (output (vector-ref x 1))
2348 (newline port)
2349 (loop1 (cdr lst) pos 0))
2350 (else
2351 (compiler-internal-error
2352 "asm-display-listing, code stream not assembled"))))
2353 (if (or (= col 0) (>= col (- text-col byte-width)))
2354 (begin
2355 (if (not (= col 0)) (newline port))
2356 (print-pos pos)
2357 (display " " port)
2358 (print-byte x)
2359 (loop1 (cdr lst) (+ pos 1) (+ (+ pos-width 1) byte-width)))
2360 (begin
2361 (print-byte x)
2362 (loop1 (cdr lst) (+ pos 1) (+ col byte-width)))))))))
2364 ;; (asm-write-code filename) outputs the code stream (i.e. the sequence
2365 ;; of bytes produced) on the named file.
2367 (define (asm-write-code filename)
2368 (with-output-to-file filename
2369 (lambda ()
2370 (let loop ((lst (cdr asm-code-stream)))
2371 (if (not (null? lst))
2372 (let ((x (car lst)))
2373 (if (vector? x)
2374 (let ((kind (vector-ref x 0)))
2375 (if (not (eq? kind 'LISTING))
2376 (compiler-internal-error
2377 "asm-write-code, code stream not assembled"))
2378 (loop (cdr lst)))
2379 (begin
2380 (write-char (integer->char x))
2381 (loop (cdr lst))))))))))
2383 (define (asm-write-hex-file filename)
2384 (with-output-to-file filename
2385 (lambda ()
2387 (define (print-hex n)
2388 (display (string-ref "0123456789ABCDEF" n)))
2390 (define (print-byte n)
2391 (print-hex (quotient n 16))
2392 (print-hex (modulo n 16)))
2394 (define (print-line type addr bytes)
2395 (let ((n (length bytes))
2396 (addr-hi (quotient addr 256))
2397 (addr-lo (modulo addr 256)))
2398 (display ":")
2399 (print-byte n)
2400 (print-byte addr-hi)
2401 (print-byte addr-lo)
2402 (print-byte type)
2403 (for-each print-byte bytes)
2404 (let ((sum
2405 (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
2406 (print-byte sum)
2407 (newline))))
2409 (let loop ((lst (cdr asm-code-stream))
2410 (pos asm-start-pos)
2411 (rev-bytes '()))
2412 (if (not (null? lst))
2413 (let ((x (car lst)))
2414 (if (vector? x)
2415 (let ((kind (vector-ref x 0)))
2416 (if (not (eq? kind 'LISTING))
2417 (compiler-internal-error
2418 "asm-write-hex-file, code stream not assembled"))
2419 (loop (cdr lst)
2420 pos
2421 rev-bytes))
2422 (let ((new-pos
2423 (+ pos 1))
2424 (new-rev-bytes
2425 (cons x
2426 (if (= (modulo pos 16) 0)
2427 (begin
2428 (print-line 0
2429 (- pos (length rev-bytes))
2430 (reverse rev-bytes))
2431 '())
2432 rev-bytes))))
2433 (loop (cdr lst)
2434 new-pos
2435 new-rev-bytes))))
2436 (begin
2437 (if (not (null? rev-bytes))
2438 (print-line 0
2439 (- pos (length rev-bytes))
2440 (reverse rev-bytes)))
2441 (print-line 1 0 '())
2442 (if #t
2443 (begin
2444 (display (- pos asm-start-pos) ##stderr-port)
2445 (display " bytes\n" ##stderr-port)))))))))
2447 ;; Utilities.
2449 (define asm-start-pos #f) ; start position of the code stream
2450 (define asm-big-endian? #f) ; endianness to use
2451 (define asm-code-stream #f) ; current code stream
2453 (define (asm-make-stream) ; create an empty stream
2454 (let ((x (cons '() '())))
2455 (set-car! x x)
2456 x))
2458 (define (asm-code-extend item) ; add an item at the end of current code stream
2459 (let* ((stream asm-code-stream)
2460 (tail (car stream))
2461 (cell (cons item '())))
2462 (set-cdr! tail cell)
2463 (set-car! stream cell)))
2465 (define (asm-pass1) ; construct fixup list and make first label assignment
2466 (let loop ((curr (cdr asm-code-stream))
2467 (fixup-lst '())
2468 (span 0)
2469 (pos asm-start-pos))
2470 (if (null? curr)
2471 (reverse fixup-lst)
2472 (let ((x (car curr)))
2473 (if (vector? x)
2474 (let ((kind (vector-ref x 0)))
2475 (cond ((eq? kind 'LABEL)
2476 (vector-set! x 1 pos) ; first approximation of position
2477 (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
2478 ((eq? kind 'DEFERRED)
2479 (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
2480 (else
2481 (loop (cdr curr) fixup-lst span pos))))
2482 (loop (cdr curr) fixup-lst (+ span 1) (+ pos 1)))))))
2484 ;(##declare (generic))
2486 (define (asm-bits-0-to-7 n) ; return bits 0 to 7 of a signed integer
2487 (modulo n #x100))
2489 (define (asm-bits-8-and-up n) ; return bits 8 and up of a signed integer
2490 (if (>= n 0)
2491 (quotient n #x100)
2492 (- (quotient (+ n 1) #x100) 1)))
2494 (define (asm-bits-16-and-up n) ; return bits 16 and up of a signed integer
2495 (if (>= n 0)
2496 (quotient n #x10000)
2497 (- (quotient (+ n 1) #x10000) 1)))
2499 (define (asm-bits-32-and-up n) ; return bits 32 and up of a signed integer
2500 (if (>= n 0)
2501 (quotient n #x100000000)
2502 (- (quotient (+ n 1) #x100000000) 1)))
2504 ; The following procedures convert floating point numbers into their
2505 ; machine representation. They perform bignum and flonum arithmetic.
2507 (define (asm-float->inexact-exponential-format x)
2509 (define (exp-form-pos x y i)
2510 (let ((i*2 (+ i i)))
2511 (let ((z (if (and (not (< asm-ieee-e-bias i*2))
2512 (not (< x y)))
2513 (exp-form-pos x (* y y) i*2)
2514 (cons x 0))))
2515 (let ((a (car z)) (b (cdr z)))
2516 (let ((i+b (+ i b)))
2517 (if (and (not (< asm-ieee-e-bias i+b))
2518 (not (< a y)))
2519 (begin
2520 (set-car! z (/ a y))
2521 (set-cdr! z i+b)))
2522 z)))))
2524 (define (exp-form-neg x y i)
2525 (let ((i*2 (+ i i)))
2526 (let ((z (if (and (< i*2 asm-ieee-e-bias-minus-1)
2527 (< x y))
2528 (exp-form-neg x (* y y) i*2)
2529 (cons x 0))))
2530 (let ((a (car z)) (b (cdr z)))
2531 (let ((i+b (+ i b)))
2532 (if (and (< i+b asm-ieee-e-bias-minus-1)
2533 (< a y))
2534 (begin
2535 (set-car! z (/ a y))
2536 (set-cdr! z i+b)))
2537 z)))))
2539 (define (exp-form x)
2540 (if (< x asm-inexact-+1)
2541 (let ((z (exp-form-neg x asm-inexact-+1/2 1)))
2542 (set-car! z (* asm-inexact-+2 (car z)))
2543 (set-cdr! z (- -1 (cdr z)))
2544 z)
2545 (exp-form-pos x asm-inexact-+2 1)))
2547 (if (negative? x)
2548 (let ((z (exp-form (- asm-inexact-0 x))))
2549 (set-car! z (- asm-inexact-0 (car z)))
2550 z)
2551 (exp-form x)))
2553 (define (asm-float->exact-exponential-format x)
2554 (let ((z (asm-float->inexact-exponential-format x)))
2555 (let ((y (car z)))
2556 (cond ((not (< y asm-inexact-+2))
2557 (set-car! z asm-ieee-+m-min)
2558 (set-cdr! z asm-ieee-e-bias-plus-1))
2559 ((not (< asm-inexact--2 y))
2560 (set-car! z asm-ieee--m-min)
2561 (set-cdr! z asm-ieee-e-bias-plus-1))
2562 (else
2563 (set-car! z
2564 (truncate (inexact->exact (* (car z) asm-inexact-m-min))))))
2565 (set-cdr! z (- (cdr z) asm-ieee-m-bits))
2566 z)))
2568 (define (asm-float->bits x) ; returns the 64 bit integer encoding the float "x"
2570 (define (bits a b)
2571 (if (< a asm-ieee-+m-min)
2572 a
2573 (+ (- a asm-ieee-+m-min)
2574 (* (+ (+ b asm-ieee-m-bits) asm-ieee-e-bias)
2575 asm-ieee-+m-min))))
2577 (let ((z (asm-float->exact-exponential-format x)))
2578 (let ((a (car z)) (b (cdr z)))
2579 (if (negative? a)
2580 (+ asm-ieee-sign-bit (bits (- 0 a) b))
2581 (bits a b)))))
2583 ; Parameters for ANSI-IEEE Std 754-1985 representation of
2584 ; doubles (i.e. 64 bit floating point numbers):
2586 (define asm-ieee-m-bits 52)
2587 (define asm-ieee-e-bits 11)
2588 (define asm-ieee-+m-min 4503599627370496) ; (expt 2 asm-ieee-m-bits)
2589 (define asm-ieee--m-min -4503599627370496) ; (- asm-ieee-+m-min)
2590 (define asm-ieee-sign-bit #x8000000000000000); (expt 2 (+ asm-ieee-e-bits asm-ieee-m-bits))
2592 (define asm-ieee-e-bias 1023) ; (- (expt 2 (- asm-ieee-e-bits 1)) 1)
2593 (define asm-ieee-e-bias-plus-1 1024) ; (+ asm-ieee-e-bias 1)
2594 (define asm-ieee-e-bias-minus-1 1022) ; (- asm-ieee-e-bias 1)
2596 (define asm-inexact-m-min (exact->inexact asm-ieee-+m-min))
2597 (define asm-inexact-+2 (exact->inexact 2))
2598 (define asm-inexact--2 (exact->inexact -2))
2599 (define asm-inexact-+1 (exact->inexact 1))
2600 (define asm-inexact-+1/2 (exact->inexact (/ 1 2)))
2601 (define asm-inexact-0 (exact->inexact 0))
2603 ;------------------------------------------------------------------------------
2605 (define min-fixnum-encoding 3)
2606 (define min-fixnum -1)
2607 (define max-fixnum 255)
2608 (define min-rom-encoding (+ min-fixnum-encoding (- max-fixnum min-fixnum) 1))
2609 (define min-ram-encoding 512)
2610 (define max-ram-encoding 4095)
2611 (define min-vec-encoding 4096)
2612 (define max-vec-encoding 8191)
2614 (define code-start #x5000)
2616 (define (predef-constants) (list))
2618 (define (predef-globals) (list))
2620 (define (encode-direct obj)
2621 (cond ((eq? obj #f)
2622 0)
2623 ((eq? obj #t)
2624 1)
2625 ((eq? obj '())
2626 2)
2627 ((and (integer? obj)
2628 (exact? obj)
2629 (>= obj min-fixnum)
2630 (<= obj max-fixnum))
2631 (+ obj (- min-fixnum-encoding min-fixnum)))
2632 (else
2633 #f)))
2635 (define (translate-constant obj)
2636 (if (char? obj)
2637 (char->integer obj)
2638 obj))
2640 (define (encode-constant obj constants)
2641 (let ((o (translate-constant obj)))
2642 (let ((e (encode-direct o)))
2643 (if e
2644 e
2645 (let ((x (assoc o constants)))
2646 (if x
2647 (vector-ref (cdr x) 0)
2648 (compiler-error "unknown object" obj)))))))
2650 ;; TODO actually, seem to be in a pair, scheme object in car, vector in cdr
2651 ;; constant objects are represented by vectors
2652 ;; 0 : encoding (ROM address) TODO really the ROM address ?
2653 ;; 1 : TODO asm label constant ?
2654 ;; 2 : number of occurences of this constant in the code
2655 ;; 3 : pointer to content, used at encoding time
2656 (define (add-constant obj constants from-code? cont)
2657 (let ((o (translate-constant obj)))
2658 (let ((e (encode-direct o)))
2659 (if e
2660 (cont constants)
2661 (let ((x (assoc o constants)))
2662 (if x
2663 (begin
2664 (if from-code?
2665 (vector-set! (cdr x) 2 (+ (vector-ref (cdr x) 2) 1)))
2666 (cont constants))
2667 (let* ((descr
2668 (vector #f
2669 (asm-make-label 'constant)
2670 (if from-code? 1 0)
2671 #f))
2672 (new-constants
2673 (cons (cons o descr)
2674 constants)))
2675 (cond ((pair? o)
2676 (add-constants (list (car o) (cdr o))
2677 new-constants
2678 cont))
2679 ((symbol? o)
2680 (cont new-constants))
2681 ((string? o)
2682 (let ((chars (map char->integer (string->list o))))
2683 (vector-set! descr 3 chars)
2684 (add-constant chars
2685 new-constants
2686 #f
2687 cont)))
2688 ((vector? o) ; ordinary vectors are stored as lists
2689 (let ((elems (vector->list o)))
2690 (vector-set! descr 3 elems)
2691 (add-constant elems
2692 new-constants
2693 #f
2694 cont)))
2695 ((u8vector? o)
2696 (let ((elems (u8vector->list o)))
2697 (vector-set! descr 3 elems)
2698 (add-constant elems
2699 new-constants
2700 #f
2701 cont)))
2702 ((and (number? o) (exact? o))
2703 ; (pp (list START-ENCODING: o))
2704 (let ((hi (arithmetic-shift o -16)))
2705 (vector-set! descr 3 hi)
2706 ;; recursion will stop once we reach 0 or -1 as the
2707 ;; high part, which will be matched by encode-direct
2708 (add-constant hi
2709 new-constants
2710 #f
2711 cont)))
2712 (else
2713 (cont new-constants))))))))))
2715 (define (add-constants objs constants cont)
2716 (if (null? objs)
2717 (cont constants)
2718 (add-constant (car objs)
2719 constants
2720 #f
2721 (lambda (new-constants)
2722 (add-constants (cdr objs)
2723 new-constants
2724 cont)))))
2726 (define (add-global var globals cont)
2727 (let ((x (assq var globals)))
2728 (if x
2729 (begin
2730 ;; increment reference counter
2731 (vector-set! (cdr x) 1 (+ (vector-ref (cdr x) 1) 1))
2732 (cont globals))
2733 (let ((new-globals
2734 (cons (cons var (vector (length globals) 1))
2735 globals)))
2736 (cont new-globals)))))
2738 (define (sort-constants constants)
2739 (let ((csts
2740 (sort-list constants
2741 (lambda (x y)
2742 (> (vector-ref (cdr x) 2)
2743 (vector-ref (cdr y) 2))))))
2744 (let loop ((i min-rom-encoding)
2745 (lst csts))
2746 (if (null? lst)
2747 ;; constants can use all the rom addresses up to 256 constants since
2748 ;; their number is encoded in a byte at the beginning of the bytecode
2749 (if (or (> i min-ram-encoding) (> (- i min-rom-encoding) 256))
2750 (compiler-error "too many constants")
2751 csts)
2752 (begin
2753 (vector-set! (cdr (car lst)) 0 i)
2754 (loop (+ i 1)
2755 (cdr lst)))))))
2757 (define (sort-globals globals) ;; TODO a lot in common with sort-constants, ABSTRACT
2758 (let ((glbs
2759 (sort-list globals
2760 (lambda (x y)
2761 (> (vector-ref (cdr x) 1)
2762 (vector-ref (cdr y) 1))))))
2763 (let loop ((i 0)
2764 (lst glbs))
2765 (if (null? lst)
2766 (if (> i 256) ;; the number of globals is encoded on a byte
2767 (compiler-error "too many global variables")
2768 glbs)
2769 (begin
2770 (vector-set! (cdr (car lst)) 0 i)
2771 (loop (+ i 1)
2772 (cdr lst)))))))
2774 (define assemble
2775 (lambda (code hex-filename)
2776 (let loop1 ((lst code)
2777 (constants (predef-constants))
2778 (globals (predef-globals))
2779 (labels (list)))
2780 (if (pair? lst)
2782 (let ((instr (car lst)))
2783 (cond ((number? instr)
2784 (loop1 (cdr lst)
2785 constants
2786 globals
2787 (cons (cons instr (asm-make-label 'label))
2788 labels)))
2789 ((eq? (car instr) 'push-constant)
2790 (add-constant (cadr instr)
2791 constants
2792 #t
2793 (lambda (new-constants)
2794 (loop1 (cdr lst)
2795 new-constants
2796 globals
2797 labels))))
2798 ((memq (car instr) '(push-global set-global))
2799 (add-global (cadr instr)
2800 globals
2801 (lambda (new-globals)
2802 (loop1 (cdr lst)
2803 constants
2804 new-globals
2805 labels))))
2806 (else
2807 (loop1 (cdr lst)
2808 constants
2809 globals
2810 labels))))
2812 (let ((constants (sort-constants constants))
2813 (globals (sort-globals globals)))
2815 (define (label-instr label opcode)
2816 (asm-at-assembly
2817 ;; if the distance from pc to the label fits in a single byte,
2818 ;; a short instruction is used, containing a relative address
2819 ;; if not, the full 16-bit label is used
2820 ;;; (lambda (self)
2821 ;;; (let ((dist (- (asm-label-pos label) self)))
2822 ;;; (and (< dist 256) ;; TODO have this between -128 and 127 ? would be more flexible, I guess
2823 ;;; (> dist 0)
2824 ;;; 2)))
2825 ;;; (lambda (self)
2826 ;;; (asm-8 (+ opcode 5))
2827 ;;; (asm-8 (- (asm-label-pos label) self)))
2828 ;; TODO doesn't work at the moment
2830 (lambda (self)
2831 3)
2832 (lambda (self)
2833 (let ((pos (- (asm-label-pos label) code-start)))
2834 (asm-8 opcode)
2835 (asm-8 (quotient pos 256))
2836 (asm-8 (modulo pos 256))))))
2838 (define (push-constant n)
2839 (if (<= n 31)
2840 (asm-8 (+ #x00 n))
2841 (begin
2842 (asm-8 (+ #x90 (quotient n 256)))
2843 (asm-8 (modulo n 256)))))
2845 (define (push-stack n)
2846 (if (> n 31)
2847 (compiler-error "stack is too deep")
2848 (asm-8 (+ #x20 n))))
2850 (define (push-global n)
2851 (if (<= n 15)
2852 (asm-8 (+ #x40 n))
2853 (begin (asm-8 #x8e)
2854 (asm-8 n))))
2856 (define (set-global n)
2857 (if (<= n 15)
2858 (asm-8 (+ #x50 n))
2859 (begin (asm-8 #x8f)
2860 (asm-8 n))))
2862 (define (call n)
2863 (if (> n 15)
2864 (compiler-error "call has too many arguments")
2865 (asm-8 (+ #x60 n))))
2867 (define (jump n)
2868 (if (> n 15)
2869 (compiler-error "call has too many arguments")
2870 (asm-8 (+ #x70 n))))
2872 (define (call-toplevel label)
2873 (label-instr label #x80))
2875 (define (jump-toplevel label)
2876 (label-instr label #x81))
2878 (define (goto label)
2879 (label-instr label #x82))
2881 (define (goto-if-false label)
2882 (label-instr label #x83))
2884 (define (closure label)
2885 (label-instr label #x84))
2887 (define (prim n)
2888 (asm-8 (+ #xc0 n)))
2890 (define (prim.number?) (prim 0))
2891 (define (prim.+) (prim 1))
2892 (define (prim.-) (prim 2))
2893 (define (prim.*) (prim 3))
2894 (define (prim.quotient) (prim 4))
2895 (define (prim.remainder) (prim 5))
2896 (define (prim.neg) (prim 6))
2897 (define (prim.=) (prim 7))
2898 (define (prim.<) (prim 8))
2899 (define (prim.ior) (prim 9))
2900 (define (prim.>) (prim 10))
2901 (define (prim.xor) (prim 11))
2902 (define (prim.pair?) (prim 12))
2903 (define (prim.cons) (prim 13))
2904 (define (prim.car) (prim 14))
2905 (define (prim.cdr) (prim 15))
2906 (define (prim.set-car!) (prim 16))
2907 (define (prim.set-cdr!) (prim 17))
2908 (define (prim.null?) (prim 18))
2909 (define (prim.eq?) (prim 19))
2910 (define (prim.not) (prim 20))
2911 (define (prim.get-cont) (prim 21))
2912 (define (prim.graft-to-cont) (prim 22))
2913 (define (prim.return-to-cont) (prim 23))
2914 (define (prim.halt) (prim 24))
2915 (define (prim.symbol?) (prim 25))
2916 (define (prim.string?) (prim 26))
2917 (define (prim.string->list) (prim 27))
2918 (define (prim.list->string) (prim 28))
2919 (define (prim.make-u8vector) (prim 29))
2920 (define (prim.u8vector-ref) (prim 30))
2921 (define (prim.u8vector-set!) (prim 31))
2922 (define (prim.print) (prim 32))
2923 (define (prim.clock) (prim 33))
2924 (define (prim.motor) (prim 34))
2925 (define (prim.led) (prim 35))
2926 (define (prim.led2-color) (prim 36))
2927 (define (prim.getchar-wait) (prim 37))
2928 (define (prim.putchar) (prim 38))
2929 (define (prim.beep) (prim 39))
2930 (define (prim.adc) (prim 40))
2931 (define (prim.u8vector?) (prim 41))
2932 (define (prim.sernum) (prim 42))
2933 (define (prim.u8vector-length) (prim 43))
2934 (define (prim.u8vector-copy!) (prim 44))
2935 (define (prim.shift) (prim 45))
2936 (define (prim.pop) (prim 46))
2937 (define (prim.return) (prim 47))
2938 (define (prim.boolean?) (prim 48))
2939 (define (prim.network-init) (prim 49))
2940 (define (prim.network-cleanup) (prim 50))
2941 (define (prim.receive-packet-to-u8vector) (prim 51))
2942 (define (prim.send-packet-from-u8vector) (prim 52))
2943 (define (prim.<=) (prim 53))
2944 (define (prim.>=) (prim 54))
2946 (define big-endian? #f)
2948 (asm-begin! code-start #f)
2950 (asm-8 #xfb)
2951 (asm-8 #xd7)
2952 (asm-8 (length constants))
2953 (asm-8 (length globals))
2955 '(pp (list constants: constants globals: globals))
2957 (for-each
2958 (lambda (x)
2959 (let* ((descr (cdr x))
2960 (label (vector-ref descr 1))
2961 (obj (car x)))
2962 (asm-label label)
2963 ;; see the vm source for a description of encodings
2964 ;; TODO have comments here to explain encoding, at least magic number that give the type
2965 (cond ((and (integer? obj) (exact? obj)) ;; TODO FOOBGIGNUMS
2966 (let ((hi (encode-constant (vector-ref descr 3)
2967 constants)))
2968 ; (pp (list ENCODE: (vector-ref descr 3) to: hi lo: obj))
2969 (asm-8 (+ 0 (arithmetic-shift hi -8))) ;; TODO -5 has low 16 at 00fb, should be fffb, 8 bits ar lost
2970 (asm-8 (bitwise-and hi #xff)) ; pointer to hi
2971 (asm-8 (arithmetic-shift obj -8)) ; bits 8-15
2972 (asm-8 (bitwise-and obj #xff)))) ; bits 0-7
2973 ((pair? obj)
2974 (let ((obj-car (encode-constant (car obj) constants))
2975 (obj-cdr (encode-constant (cdr obj) constants)))
2976 (asm-8 (+ #x80 (arithmetic-shift obj-car -8)))
2977 (asm-8 (bitwise-and obj-car #xff))
2978 (asm-8 (+ 0 (arithmetic-shift obj-cdr -8)))
2979 (asm-8 (bitwise-and obj-cdr #xff))))
2980 ((symbol? obj)
2981 (asm-8 #x80)
2982 (asm-8 0)
2983 (asm-8 #x20)
2984 (asm-8 0))
2985 ((string? obj)
2986 (let ((obj-enc (encode-constant (vector-ref descr 3)
2987 constants)))
2988 (asm-8 (+ #x80 (arithmetic-shift obj-enc -8)))
2989 (asm-8 (bitwise-and obj-enc #xff))
2990 (asm-8 #x40)
2991 (asm-8 0)))
2992 ((vector? obj) ; ordinary vectors are stored as lists
2993 (let* ((elems (vector-ref descr 3))
2994 (obj-car (encode-constant (car elems)
2995 constants))
2996 (obj-cdr (encode-constant (cdr elems)
2997 constants)))
2998 (asm-8 (+ #x80 (arithmetic-shift obj-car -8)))
2999 (asm-8 (bitwise-and obj-car #xff))
3000 (asm-8 (+ 0 (arithmetic-shift obj-cdr -8)))
3001 (asm-8 (bitwise-and obj-cdr #xff))))
3002 ((u8vector? obj)
3003 (let ((obj-enc (encode-constant (vector-ref descr 3)
3004 constants))
3005 (l (length (vector-ref descr 3))))
3006 ;; length is stored raw, not encoded as an object
3007 ;; however, the bytes of content are encoded as
3008 ;; fixnums
3009 (asm-8 (+ #x80 (arithmetic-shift l -8)))
3010 (asm-8 (bitwise-and l #xff))
3011 (asm-8 (+ #x60 (arithmetic-shift obj-enc -8)))
3012 (asm-8 (bitwise-and obj-enc #xff))))
3013 (else
3014 (compiler-error "unknown object type" obj)))))
3015 constants)
3017 (let loop2 ((lst code))
3018 (if (pair? lst)
3019 (let ((instr (car lst)))
3021 (cond ((number? instr)
3022 (let ((label (cdr (assq instr labels))))
3023 (asm-label label)))
3025 ((eq? (car instr) 'entry)
3026 (let ((np (cadr instr))
3027 (rest? (caddr instr)))
3028 (asm-8 (if rest? (- np) np))))
3030 ((eq? (car instr) 'push-constant)
3031 (let ((n (encode-constant (cadr instr) constants)))
3032 (push-constant n)))
3034 ((eq? (car instr) 'push-stack)
3035 (push-stack (cadr instr)))
3037 ((eq? (car instr) 'push-global)
3038 (push-global (vector-ref
3039 (cdr (assq (cadr instr) globals))
3040 0)))
3042 ((eq? (car instr) 'set-global)
3043 (set-global (vector-ref
3044 (cdr (assq (cadr instr) globals))
3045 0)))
3047 ((eq? (car instr) 'call)
3048 (call (cadr instr)))
3050 ((eq? (car instr) 'jump)
3051 (jump (cadr instr)))
3053 ((eq? (car instr) 'call-toplevel)
3054 (let ((label (cdr (assq (cadr instr) labels))))
3055 (call-toplevel label)))
3057 ((eq? (car instr) 'jump-toplevel)
3058 (let ((label (cdr (assq (cadr instr) labels))))
3059 (jump-toplevel label)))
3061 ((eq? (car instr) 'goto)
3062 (let ((label (cdr (assq (cadr instr) labels))))
3063 (goto label)))
3065 ((eq? (car instr) 'goto-if-false)
3066 (let ((label (cdr (assq (cadr instr) labels))))
3067 (goto-if-false label)))
3069 ((eq? (car instr) 'closure)
3070 (let ((label (cdr (assq (cadr instr) labels))))
3071 (closure label)))
3073 ((eq? (car instr) 'prim)
3074 (case (cadr instr)
3075 ((#%number?) (prim.number?))
3076 ((#%+) (prim.+))
3077 ((#%-) (prim.-))
3078 ((#%*) (prim.*))
3079 ((#%quotient) (prim.quotient))
3080 ((#%remainder) (prim.remainder))
3081 ((#%neg) (prim.neg))
3082 ((#%=) (prim.=))
3083 ((#%<) (prim.<))
3084 ((#%ior) (prim.ior))
3085 ((#%>) (prim.>))
3086 ((#%xor) (prim.xor))
3087 ((#%pair?) (prim.pair?))
3088 ((#%cons) (prim.cons))
3089 ((#%car) (prim.car))
3090 ((#%cdr) (prim.cdr))
3091 ((#%set-car!) (prim.set-car!))
3092 ((#%set-cdr!) (prim.set-cdr!))
3093 ((#%null?) (prim.null?))
3094 ((#%eq?) (prim.eq?))
3095 ((#%not) (prim.not))
3096 ((#%get-cont) (prim.get-cont))
3097 ((#%graft-to-cont) (prim.graft-to-cont))
3098 ((#%return-to-cont) (prim.return-to-cont))
3099 ((#%halt) (prim.halt))
3100 ((#%symbol?) (prim.symbol?))
3101 ((#%string?) (prim.string?))
3102 ((#%string->list) (prim.string->list))
3103 ((#%list->string) (prim.list->string))
3104 ((#%make-u8vector) (prim.make-u8vector))
3105 ((#%u8vector-ref) (prim.u8vector-ref))
3106 ((#%u8vector-set!) (prim.u8vector-set!))
3107 ((#%print) (prim.print))
3108 ((#%clock) (prim.clock))
3109 ((#%motor) (prim.motor))
3110 ((#%led) (prim.led))
3111 ((#%led2-color) (prim.led2-color))
3112 ((#%getchar-wait ) (prim.getchar-wait))
3113 ((#%putchar) (prim.putchar))
3114 ((#%beep) (prim.beep))
3115 ((#%adc) (prim.adc))
3116 ((#%u8vector?) (prim.u8vector?))
3117 ((#%sernum) (prim.sernum))
3118 ((#%u8vector-length) (prim.u8vector-length))
3119 ((#%u8vector-copy!) (prim.u8vector-copy!))
3120 ((#%boolean?) (prim.boolean?))
3121 ((#%network-init) (prim.network-init))
3122 ((#%network-cleanup) (prim.network-cleanup))
3123 ((#%receive-packet-to-u8vector) (prim.receive-packet-to-u8vector))
3124 ((#%send-packet-from-u8vector) (prim.send-packet-from-u8vector))
3125 ((#%<=) (prim.<=))
3126 ((#%>=) (prim.>=))
3127 (else
3128 (compiler-error "unknown primitive" (cadr instr)))))
3130 ((eq? (car instr) 'return)
3131 (prim.return))
3133 ((eq? (car instr) 'pop)
3134 (prim.pop))
3136 ((eq? (car instr) 'shift)
3137 (prim.shift))
3139 (else
3140 (compiler-error "unknown instruction" instr)))
3142 (loop2 (cdr lst)))))
3144 (asm-assemble)
3146 (asm-write-hex-file hex-filename)
3148 (asm-end!))))))
3150 (define execute
3151 (lambda (hex-filename)
3152 '
3153 (if #f
3154 (begin
3155 (shell-command "gcc -o picobit-vm picobit-vm.c")
3156 (shell-command (string-append "./picobit-vm " hex-filename)))
3157 (shell-command (string-append "./robot . 1 " hex-filename)))))
3159 (define (sort-list l <?)
3161 (define (mergesort l)
3163 (define (merge l1 l2)
3164 (cond ((null? l1) l2)
3165 ((null? l2) l1)
3166 (else
3167 (let ((e1 (car l1)) (e2 (car l2)))
3168 (if (<? e1 e2)
3169 (cons e1 (merge (cdr l1) l2))
3170 (cons e2 (merge l1 (cdr l2))))))))
3172 (define (split l)
3173 (if (or (null? l) (null? (cdr l)))
3174 l
3175 (cons (car l) (split (cddr l)))))
3177 (if (or (null? l) (null? (cdr l)))
3178 l
3179 (let* ((l1 (mergesort (split l)))
3180 (l2 (mergesort (split (cdr l)))))
3181 (merge l1 l2))))
3183 (mergesort l))
3185 ;------------------------------------------------------------------------------
3187 (define compile
3188 (lambda (filename)
3189 (let* ((node (parse-file filename))
3190 (hex-filename
3191 (string-append
3192 (path-strip-extension filename)
3193 ".hex")))
3195 (adjust-unmutable-references! node)
3197 ; (pp (node->expr node))
3199 (let ((ctx (comp-none node (make-init-context))))
3200 (let ((prog (linearize (optimize-code (context-code ctx)))))
3201 ; (pp (list code: prog env: (context-env ctx)))
3202 (assemble prog hex-filename)
3203 (execute hex-filename))))))
3206 (define main
3207 (lambda (filename)
3208 (compile filename)))
3210 ;------------------------------------------------------------------------------
3212 '
3213 (define (asm-write-hex-file filename)
3214 (with-output-to-file filename
3215 (lambda ()
3217 (define (print-hex n)
3218 (display (string-ref "0123456789ABCDEF" n)))
3220 (define (print-byte n)
3221 (display ", 0x")
3222 (print-hex (quotient n 16))
3223 (print-hex (modulo n 16)))
3225 (define (print-line type addr bytes)
3226 (let ((n (length bytes))
3227 (addr-hi (quotient addr 256))
3228 (addr-lo (modulo addr 256)))
3229 ; (display ":")
3230 ; (print-byte n)
3231 ; (print-byte addr-hi)
3232 ; (print-byte addr-lo)
3233 ; (print-byte type)
3234 (for-each print-byte bytes)
3235 (let ((sum
3236 (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
3237 ; (print-byte sum)
3238 (newline))))
3240 (let loop ((lst (cdr asm-code-stream))
3241 (pos asm-start-pos)
3242 (rev-bytes '()))
3243 (if (not (null? lst))
3244 (let ((x (car lst)))
3245 (if (vector? x)
3246 (let ((kind (vector-ref x 0)))
3247 (if (not (eq? kind 'LISTING))
3248 (compiler-internal-error
3249 "asm-write-hex-file, code stream not assembled"))
3250 (loop (cdr lst)
3251 pos
3252 rev-bytes))
3253 (let ((new-pos
3254 (+ pos 1))
3255 (new-rev-bytes
3256 (cons x
3257 (if (= (modulo pos 8) 0)
3258 (begin
3259 (print-line 0
3260 (- pos (length rev-bytes))
3261 (reverse rev-bytes))
3262 '())
3263 rev-bytes))))
3264 (loop (cdr lst)
3265 new-pos
3266 new-rev-bytes))))
3267 (begin
3268 (if (not (null? rev-bytes))
3269 (print-line 0
3270 (- pos (length rev-bytes))
3271 (reverse rev-bytes)))
3272 (print-line 1 0 '())))))))