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