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