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