| blob | 004b3749af11d82819a50c138f05e840f1d865fc |
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 (make-var '#%number? #t '() '() '() #f (make-primitive 1 #f #f))
206 (make-var '#%+ #t '() '() '() #f (make-primitive 2 #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 '#%quotient #t '() '() '() #f (make-primitive 2 #f #f))
210 (make-var '#%remainder #t '() '() '() #f (make-primitive 2 #f #f))
211 (make-var '#%neg #t '() '() '() #f (make-primitive 1 #f #f))
212 (make-var '#%= #t '() '() '() #f (make-primitive 2 #f #f))
213 (make-var '#%< #t '() '() '() #f (make-primitive 2 #f #f))
214 (make-var '#%ior #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED
215 (make-var '#%> #t '() '() '() #f (make-primitive 2 #f #f))
216 (make-var '#%xor #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED
217 (make-var '#%pair? #t '() '() '() #f (make-primitive 1 #f #f))
218 (make-var '#%cons #t '() '() '() #f (make-primitive 2 #f #f))
219 (make-var '#%car #t '() '() '() #f (make-primitive 1 #f #f))
220 (make-var '#%cdr #t '() '() '() #f (make-primitive 1 #f #f))
221 (make-var '#%set-car! #t '() '() '() #f (make-primitive 2 #f #t))
222 (make-var '#%set-cdr! #t '() '() '() #f (make-primitive 2 #f #t))
223 (make-var '#%null? #t '() '() '() #f (make-primitive 1 #f #f))
224 (make-var '#%eq? #t '() '() '() #f (make-primitive 2 #f #f))
225 (make-var '#%not #t '() '() '() #f (make-primitive 1 #f #f))
226 (make-var '#%get-cont #t '() '() '() #f (make-primitive 0 #f #f))
227 (make-var '#%graft-to-cont #t '() '() '() #f (make-primitive 2 #f #f))
228 (make-var '#%return-to-cont #t '() '() '() #f (make-primitive 2 #f #f))
229 (make-var '#%halt #t '() '() '() #f (make-primitive 0 #f #t))
230 (make-var '#%symbol? #t '() '() '() #f (make-primitive 1 #f #f))
231 (make-var '#%string? #t '() '() '() #f (make-primitive 1 #f #f))
232 (make-var '#%string->list #t '() '() '() #f (make-primitive 1 #f #f))
233 (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))
239 (make-var '#%print #t '() '() '() #f (make-primitive 1 #f #t))
240 (make-var '#%clock #t '() '() '() #f (make-primitive 0 #f #f))
241 (make-var '#%motor #t '() '() '() #f (make-primitive 2 #f #t))
242 (make-var '#%led #t '() '() '() #f (make-primitive 3 #f #t))
243 (make-var '#%led2-color #t '() '() '() #f (make-primitive 1 #f #t))
244 (make-var '#%getchar-wait #t '() '() '() #f (make-primitive 2 #f #f))
245 (make-var '#%putchar #t '() '() '() #f (make-primitive 2 #f #t))
246 (make-var '#%beep #t '() '() '() #f (make-primitive 2 #f #f))
247 (make-var '#%adc #t '() '() '() #f (make-primitive 1 #f #f))
248 (make-var '#%u8vector? #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED, was dac
249 (make-var '#%sernum #t '() '() '() #f (make-primitive 0 #f #f))
250 (make-var '#%u8vector-length #t '() '() '() #f (make-primitive 1 #f #f))
251 (make-var '#%u8vector-copy! #t '() '() '() #f (make-primitive 5 #f #t))
253 (make-var '#%readyq #t '() '() '() #f #f)
254 )))
256 ;; list of primitives that can be safely substituted for the equivalent
257 ;; function when it is called.
258 ;; this saves the calls to the primitive wrapper functions, which are still
259 ;; needed if a program needs the value of a "primitive", for example in :
260 ;; (define foo car)
261 (define substitute-primitives
262 '((number? . #%number?)
263 (quotient . #%quotient)
264 (remainder . #%remainder)
265 (= . #%=)
266 (< . #%<)
267 (> . #%>)
268 (pair? . #%pair?)
269 (cons . #%cons)
270 (car . #%car)
271 (cdr . #%cdr)
272 (set-car! . #%set-car!)
273 (set-cdr! . #%set-cdr!)
274 (null? . #%null?)
275 (eq? . #%eq?)
276 (not . #%not)
277 (modulo . #%remainder)
278 (string->list . #%string->list)
279 (list->string . #%list->string)
280 (clock . #%clock)
281 (beep . #%beep)
282 (light . #%adc)
283 (adc . #%adc)
284 (sernum . #%sernum)
285 (motor . #%motor)
286 (led . #%led)
287 (bitwise-ior . #%ior)
288 (bitwise-xor . #%xor)
289 (current-time . #%clock)
290 (u8vector-length . #%u8vector-length)
291 (u8vector-ref . #%u8vector-ref)
292 (u8vector-set! . #%u8vector-set!)
293 (make-u8vector . #%make-u8vector)
294 (u8vector-copy! . #%u8vector-copy!)
295 ))
297 (define env-lookup
298 (lambda (env id)
299 (let loop ((lst env) (id id))
300 (let ((b (car lst)))
301 (cond ((and (renaming? b)
302 (assq id (renaming-renamings b)))
303 =>
304 (lambda (x)
305 (loop (cdr lst) (cadr x))))
306 ((and (var? b)
307 (eq? (var-id b) id))
308 b)
309 ((null? (cdr lst))
310 (let ((x (make-var id #t '() '() '() #f #f)))
311 (set-cdr! lst (cons x '()))
312 x))
313 (else
314 (loop (cdr lst) id)))))))
316 (define env-extend
317 (lambda (env ids def)
318 (append (map (lambda (id)
319 (make-var id #f '() '() (list def) #f #f))
320 ids)
321 env)))
323 (define env-extend-renamings
324 (lambda (env renamings)
325 (cons (make-renaming renamings) env)))
327 (define *macros* '())
329 ;-----------------------------------------------------------------------------
331 ;; Parsing.
333 (define parse-program
334 (lambda (expr env)
335 (let ((x (parse-top expr env)))
336 (cond ((null? x)
337 (parse 'value #f env))
338 ((null? (cdr x))
339 (car x))
340 (else
341 (let ((r (make-seq #f x)))
342 (for-each (lambda (y) (node-parent-set! y r)) x)
343 r))))))
345 (define parse-top
346 (lambda (expr env)
347 (cond ((and (pair? expr)
348 (eq? (car expr) 'define-macro))
349 (set! *macros*
350 (cons (cons (caadr expr)
351 (eval `(lambda ,(cdadr expr) . ,(cddr expr))))
352 *macros*))
353 '())
354 ((and (pair? expr)
355 (eq? (car expr) 'begin))
356 (parse-top-list (cdr expr) env))
357 ((and (pair? expr)
358 (eq? (car expr) 'hide))
359 (parse-top-hide (cadr expr) (cddr expr) env))
360 ((and (pair? expr)
361 (eq? (car expr) 'rename))
362 (parse-top-rename (cadr expr) (cddr expr) env))
363 ((and (pair? expr)
364 (eq? (car expr) 'define))
365 (let ((var
366 (if (pair? (cadr expr))
367 (car (cadr expr))
368 (cadr expr)))
369 (val
370 (if (pair? (cadr expr))
371 (cons 'lambda (cons (cdr (cadr expr)) (cddr expr)))
372 (caddr expr))))
373 (let* ((var2 (env-lookup env var))
374 (val2 (parse 'value val env))
375 (r (make-def #f (list val2) var2)))
376 (node-parent-set! val2 r)
377 (var-defs-set! var2 (cons r (var-defs var2)))
378 (list r))))
379 (else
380 (list (parse 'value expr env))))))
382 (define parse-top-list
383 (lambda (lst env)
384 (if (pair? lst)
385 (append (parse-top (car lst) env)
386 (parse-top-list (cdr lst) env))
387 '())))
389 (define parse-top-hide
390 (lambda (renamings body env)
391 (append
392 (parse-top-list body
393 (env-extend-renamings env renamings))
394 #|
395 (parse-top-list
396 (map (lambda (x) (list 'define (car x) (cadr x))) renamings)
397 env)
398 |#
399 )))
401 (define parse-top-rename
402 (lambda (renamings body env)
403 (parse-top-list body
404 (env-extend-renamings env renamings))))
406 (define parse
407 (lambda (use expr env)
408 (cond ((self-eval? expr)
409 (make-cst #f '() expr))
410 ((symbol? expr)
411 (let* ((var (env-lookup env expr))
412 (r (make-ref #f '() var)))
413 (var-refs-set! var (cons r (var-refs var)))
414 (if (not (var-global? var))
415 (let* ((unbox (parse 'value '#%unbox env))
416 (app (make-call #f (list unbox r))))
417 (node-parent-set! r app)
418 (node-parent-set! unbox app)
419 app)
420 r)))
421 ((and (pair? expr)
422 (assq (car expr) *macros*))
423 => (lambda (p) (parse use (apply (cdr p) (cdr expr)) env)))
424 ((and (pair? expr)
425 (eq? (car expr) 'set!))
426 (let ((var (env-lookup env (cadr expr))))
427 (if (var-global? var)
428 (let* ((val (parse 'value (caddr expr) env))
429 (r (make-set #f (list val) var)))
430 (node-parent-set! val r)
431 (var-sets-set! var (cons r (var-sets var)))
432 r)
433 (let* ((body (parse 'value (caddr expr) env))
434 (ref (make-ref #f '() var))
435 (bs (make-ref #f '() (env-lookup env '#%box-set!)))
436 (r (make-call #f (list bs ref body))))
437 (node-parent-set! body r)
438 (node-parent-set! ref r)
439 (node-parent-set! bs r)
440 (var-sets-set! var (cons r (var-sets var)))
441 r))))
442 ((and (pair? expr)
443 (eq? (car expr) 'quote))
444 (make-cst #f '() (cadr expr)))
445 ((and (pair? expr)
446 (eq? (car expr) 'if))
447 (let* ((a (parse 'test (cadr expr) env))
448 (b (parse use (caddr expr) env))
449 (c (if (null? (cdddr expr))
450 (make-cst #f '() #f)
451 (parse use (cadddr expr) env)))
452 (r (make-if #f (list a b c))))
453 (node-parent-set! a r)
454 (node-parent-set! b r)
455 (node-parent-set! c r)
456 r))
457 ((and (pair? expr)
458 (eq? (car expr) 'lambda))
459 (let* ((pattern (cadr expr))
460 (ids (extract-ids pattern))
461 ;; parent children params rest? entry-label
462 (r (make-prc #f '() #f (has-rest-param? pattern) #f))
463 (new-env (env-extend env ids r))
464 (body (parse-body (cddr expr) new-env))
465 (mut-vars
466 (apply append
467 (map (lambda (id)
468 (let ((v (env-lookup new-env id)))
469 (if (mutable-var? v) (list v) '())))
470 ids))))
471 (if (null? mut-vars)
472 (begin
473 (prc-params-set! r
474 (map (lambda (id) (env-lookup new-env id))
475 ids))
476 (node-children-set! r (list body))
477 (node-parent-set! body r)
478 r)
479 (let* ((prc (make-prc #f (list body) mut-vars #f #f))
480 (new-vars (map var-id mut-vars))
481 (tmp-env (env-extend env new-vars r))
482 (app
483 (make-call
484 r
485 (cons prc
486 (map (lambda (id)
487 (parse 'value
488 (cons '#%box (cons id '()))
489 tmp-env))
490 new-vars)))))
491 ;; (lambda (a b) (set! a b))
492 ;; => (lambda (_a b) ((lambda (a) (box-set! a b)) (box _a)))
493 (for-each (lambda (var) (var-defs-set! var (list prc)))
494 mut-vars)
495 (for-each (lambda (n) (node-parent-set! n app))
496 (cdr (node-children app)))
497 (node-parent-set! prc app)
498 (prc-params-set! r
499 (map (lambda (id) (env-lookup tmp-env id))
500 ids))
501 (node-children-set! r (list app))
502 (node-parent-set! body prc)
503 r))))
504 ((and (pair? expr)
505 (eq? (car expr) 'letrec))
506 (let ((ks (map car (cadr expr)))
507 (vs (map cadr (cadr expr))))
508 (parse use
509 (cons 'let
510 (cons (map (lambda (k) (list k #f)) ks)
511 (append (map (lambda (k v) (list 'set! k v))
512 ks vs) ; letrec*
513 (cddr expr))))
514 env)))
515 ((and (pair? expr)
516 (eq? (car expr) 'begin))
517 (let* ((exprs (map (lambda (x) (parse 'value x env)) (cdr expr)))
518 (r (make-seq #f exprs)))
519 (for-each (lambda (x) (node-parent-set! x r)) exprs)
520 r))
521 ((and (pair? expr)
522 (eq? (car expr) 'let))
523 (if (symbol? (cadr expr))
524 (parse use
525 `(letrec ((,(cadr expr) (lambda ,(map car (caddr expr)) .
526 ,(cdddr expr))))
527 (,(cadr expr) . ,(map cadr (caddr expr))))
528 env)
529 (parse use
530 (cons (cons 'lambda
531 (cons (map car (cadr expr))
532 (cddr expr)))
533 (map cadr (cadr expr)))
534 env)))
535 ((and (pair? expr)
536 (eq? (car expr) 'let*))
537 (if (null? (cadr expr))
538 (parse use
539 (cons 'let (cdr expr))
540 env)
541 (parse use
542 (list 'let
543 (list (list (caar (cadr expr))
544 (cadar (cadr expr))))
545 (cons 'let*
546 (cons (cdr (cadr expr))
547 (cddr expr))))
548 env)))
549 ((and (pair? expr)
550 (eq? (car expr) 'and))
551 (cond ((null? (cdr expr))
552 (parse use
553 #t
554 env))
555 ((null? (cddr expr))
556 (parse use
557 (cadr expr)
558 env))
559 (else
560 (parse use
561 (list 'if
562 (cadr expr)
563 (cons 'and (cddr expr))
564 #f)
565 env))))
566 ((and (pair? expr)
567 (eq? (car expr) 'or))
568 (cond ((null? (cdr expr))
569 (parse use
570 #f
571 env))
572 ((null? (cddr expr))
573 (parse use
574 (cadr expr)
575 env))
576 ((eq? use 'test)
577 (parse use
578 (list 'if
579 (cadr expr)
580 #t
581 (cons 'or (cddr expr)))
582 env))
583 (else
584 (parse use
585 (let ((v (gensym)))
586 (list 'let
587 (list (list v (cadr expr)))
588 (list 'if
589 v
590 v
591 (cons 'or (cddr expr)))))
592 env))))
593 ;; primitive substitution here
594 ;; TODO do this optimization in the following pass instead of at parse time ?
595 ((and (pair? expr)
596 (assoc (car expr) substitute-primitives))
597 =>
598 (lambda (prim)
599 (parse use
600 (cons (cdr prim) (cdr expr))
601 env)))
602 ;; binary arthimetic operations can use primitives directly
603 ;; TODO if more than one arg, unroll ? would save calls
604 ((and (pair? expr)
605 (= (length (cdr expr)) 2)
606 (assoc (car expr) '((+ . #%+) (- . #%-) (* . #%*))))
607 =>
608 (lambda (prim)
609 (parse use
610 (cons (cdr prim) (cdr expr))
611 env)))
612 ((and (pair? expr)
613 (memq (car expr)
614 '(quote quasiquote unquote unquote-splicing lambda if
615 set! cond and or case let let* letrec begin do define
616 delay)))
617 (compiler-error "the compiler does not implement the special form" (car expr)))
618 ((pair? expr)
619 (let* ((exprs (map (lambda (x) (parse 'value x env)) expr))
620 (r (make-call #f exprs)))
621 (for-each (lambda (x) (node-parent-set! x r)) exprs)
622 r))
623 (else
624 (compiler-error "unknown expression" expr)))))
626 (define parse-body
627 (lambda (exprs env)
628 (parse 'value (cons 'begin exprs) env)))
630 (define self-eval?
631 (lambda (expr)
632 (or (number? expr)
633 (char? expr)
634 (boolean? expr)
635 (string? expr))))
637 (define extract-ids
638 (lambda (pattern)
639 (if (pair? pattern)
640 (cons (car pattern) (extract-ids (cdr pattern)))
641 (if (symbol? pattern)
642 (cons pattern '())
643 '()))))
645 (define has-rest-param?
646 (lambda (pattern)
647 (if (pair? pattern)
648 (has-rest-param? (cdr pattern))
649 (symbol? pattern))))
651 (define (adjust-unmutable-references! node)
652 '(pretty-print (list unmut: (node->expr node)))
653 (if (and (call? node)
654 '(display "call ")
655 (ref? (car (node-children node)))
656 '(display "ref ")
657 (eq? '#%unbox (var-id (ref-var (car (node-children node)))))
658 '(display "unbox")
659 (ref? (cadr (node-children node)))
660 '(display "ref ")
661 (not (mutable-var? (ref-var (cadr (node-children node)))))
662 '(display "unmut! "))
663 (let* ((parent (node-parent node)) (child (cadr (node-children node))))
664 (node-parent-set! child parent)
665 (if parent
666 (node-children-set! parent
667 (map (lambda (c) (if (eq? c node) child c))
668 (node-children parent))))
669 child)
670 (begin (for-each (lambda (n) (adjust-unmutable-references! n))
671 (node-children node))
672 node)))
674 ;-----------------------------------------------------------------------------
676 ;; Compilation context representation.
678 (define-type context
679 code
680 env
681 env2
682 )
684 (define context-change-code
685 (lambda (ctx code)
686 (make-context code
687 (context-env ctx)
688 (context-env2 ctx))))
690 (define context-change-env
691 (lambda (ctx env)
692 (make-context (context-code ctx)
693 env
694 (context-env2 ctx))))
696 (define context-change-env2
697 (lambda (ctx env2)
698 (make-context (context-code ctx)
699 (context-env ctx)
700 env2)))
702 (define make-init-context
703 (lambda ()
704 (make-context (make-init-code)
705 (make-init-env)
706 #f)))
708 (define context-make-label
709 (lambda (ctx)
710 (context-change-code ctx (code-make-label (context-code ctx)))))
712 (define context-last-label
713 (lambda (ctx)
714 (code-last-label (context-code ctx))))
716 (define context-add-bb
717 (lambda (ctx label)
718 (context-change-code ctx (code-add-bb (context-code ctx) label))))
720 (define context-add-instr
721 (lambda (ctx instr)
722 (context-change-code ctx (code-add-instr (context-code ctx) instr))))
724 ;; Representation of code.
726 (define-type code
727 last-label
728 rev-bbs
729 )
731 (define-type bb
732 label
733 rev-instrs
734 )
736 (define make-init-code
737 (lambda ()
738 (make-code 0
739 (list (make-bb 0 (list))))))
741 (define code-make-label
742 (lambda (code)
743 (let ((label (+ (code-last-label code) 1)))
744 (make-code label
745 (code-rev-bbs code)))))
747 (define code-add-bb
748 (lambda (code label)
749 (make-code
750 (code-last-label code)
751 (cons (make-bb label '())
752 (code-rev-bbs code)))))
754 (define code-add-instr
755 (lambda (code instr)
756 (let* ((rev-bbs (code-rev-bbs code))
757 (bb (car rev-bbs))
758 (rev-instrs (bb-rev-instrs bb)))
759 (make-code
760 (code-last-label code)
761 (cons (make-bb (bb-label bb)
762 (cons instr rev-instrs))
763 (cdr rev-bbs))))))
765 ;; Representation of compile-time stack.
767 (define-type stack
768 size ; number of slots
769 slots ; for each slot, the variable (or #f) contained in the slot
770 )
772 (define make-init-stack
773 (lambda ()
774 (make-stack 0 '())))
776 (define stack-extend
777 (lambda (x nb-slots stk)
778 (let ((size (stack-size stk)))
779 (make-stack
780 (+ size nb-slots)
781 (append (repeat nb-slots x) (stack-slots stk))))))
783 (define stack-discard
784 (lambda (nb-slots stk)
785 (let ((size (stack-size stk)))
786 (make-stack
787 (- size nb-slots)
788 (list-tail (stack-slots stk) nb-slots)))))
790 ;; Representation of compile-time environment.
792 (define-type env
793 local
794 closed
795 )
797 (define make-init-env
798 (lambda ()
799 (make-env (make-init-stack)
800 '())))
802 (define env-change-local
803 (lambda (env local)
804 (make-env local
805 (env-closed env))))
807 (define env-change-closed
808 (lambda (env closed)
809 (make-env (env-local env)
810 closed)))
812 (define find-local-var
813 (lambda (var env)
814 (let ((i (pos-in-list var (stack-slots (env-local env)))))
815 (or i
816 (- (+ (pos-in-list var (env-closed env)) 1))))))
818 (define prc->env
819 (lambda (prc)
820 (make-env
821 (let ((params (prc-params prc)))
822 (make-stack (length params)
823 (append (map var-id params) '())))
824 (let ((vars (varset->list (non-global-fv prc))))
825 ; (pp (map var-id vars))
826 (map var-id vars)))))
828 ;-----------------------------------------------------------------------------
830 (define gen-instruction
831 (lambda (instr nb-pop nb-push ctx)
832 (let* ((env
833 (context-env ctx))
834 (stk
835 (stack-extend #f
836 nb-push
837 (stack-discard nb-pop
838 (env-local env)))))
839 (context-add-instr (context-change-env ctx (env-change-local env stk))
840 instr))))
842 (define gen-entry
843 (lambda (nparams rest? ctx)
844 (gen-instruction (list 'entry nparams rest?) 0 0 ctx)))
846 (define gen-push-constant
847 (lambda (val ctx)
848 (gen-instruction (list 'push-constant val) 0 1 ctx)))
850 (define gen-push-unspecified
851 (lambda (ctx)
852 (gen-push-constant #f ctx)))
854 (define gen-push-local-var
855 (lambda (var ctx)
856 ; (pp (list var: var local: (stack-slots (env-local (context-env ctx))) (env-closed (context-env ctx))))
857 (let ((i (find-local-var var (context-env ctx))))
858 (if (>= i 0)
859 (gen-push-stack i ctx)
860 (gen-push-stack
861 (+ 1 ;; TODO the +1 was added because closures are not really pairs anymore, they only have a cdr
862 (- -1 i)
863 (length (stack-slots (env-local (context-env ctx))))) ctx)))))
865 (define gen-push-stack
866 (lambda (pos ctx)
867 (gen-instruction (list 'push-stack pos) 0 1 ctx)))
869 (define gen-push-global
870 (lambda (var ctx)
871 (gen-instruction (list 'push-global var) 0 1 ctx)))
873 (define gen-set-global
874 (lambda (var ctx)
875 (gen-instruction (list 'set-global var) 1 0 ctx)))
877 (define gen-call
878 (lambda (nargs ctx)
879 (gen-instruction (list 'call nargs) (+ nargs 1) 1 ctx)))
881 (define gen-jump
882 (lambda (nargs ctx)
883 (gen-instruction (list 'jump nargs) (+ nargs 1) 1 ctx)))
885 (define gen-call-toplevel
886 (lambda (nargs id ctx)
887 (gen-instruction (list 'call-toplevel id) nargs 1 ctx)))
889 (define gen-jump-toplevel
890 (lambda (nargs id ctx)
891 (gen-instruction (list 'jump-toplevel id) nargs 1 ctx)))
893 (define gen-goto
894 (lambda (label ctx)
895 (gen-instruction (list 'goto label) 0 0 ctx)))
897 (define gen-goto-if-false
898 (lambda (label-false label-true ctx)
899 (gen-instruction (list 'goto-if-false label-false label-true) 1 0 ctx)))
901 (define gen-closure
902 (lambda (label-entry ctx)
903 (gen-instruction (list 'closure label-entry) 1 1 ctx)))
905 (define gen-prim
906 (lambda (id nargs unspec-result? ctx)
907 (gen-instruction
908 (list 'prim id)
909 nargs
910 (if unspec-result? 0 1)
911 ctx)))
913 (define gen-shift
914 (lambda (n ctx)
915 (if (> n 0)
916 (gen-instruction (list 'shift) 1 0 (gen-shift (- n 1) ctx))
917 ctx)))
919 (define gen-pop
920 (lambda (ctx)
921 (gen-instruction (list 'pop) 1 0 ctx)))
923 (define gen-return
924 (lambda (ctx)
925 (let ((ss (stack-size (env-local (context-env ctx)))))
926 (gen-instruction (list 'return) ss 0 ctx))))
928 ;-----------------------------------------------------------------------------
930 (define child1
931 (lambda (node)
932 (car (node-children node))))
934 (define child2
935 (lambda (node)
936 (cadr (node-children node))))
938 (define child3
939 (lambda (node)
940 (caddr (node-children node))))
942 (define comp-none
943 (lambda (node ctx)
945 (cond ((or (cst? node)
946 (ref? node)
947 (prc? node))
948 ctx)
950 ((def? node)
951 (let ((var (def-var node)))
952 (if (toplevel-prc-with-non-rest-correct-calls? var)
953 (comp-prc (child1 node) #f ctx)
954 (if (var-needed? var)
955 (let ((ctx2 (comp-push (child1 node) ctx)))
956 (gen-set-global (var-id var) ctx2))
957 (comp-none (child1 node) ctx)))))
959 ((set? node)
960 (let ((var (set-var node)))
961 (if (var-needed? var)
962 (let ((ctx2 (comp-push (child1 node) ctx)))
963 (gen-set-global (var-id var) ctx2))
964 (comp-none (child1 node) ctx))))
966 ((if? node)
967 (let* ((ctx2
968 (context-make-label ctx))
969 (label-then
970 (context-last-label ctx2))
971 (ctx3
972 (context-make-label ctx2))
973 (label-else
974 (context-last-label ctx3))
975 (ctx4
976 (context-make-label ctx3))
977 (label-then-join
978 (context-last-label ctx4))
979 (ctx5
980 (context-make-label ctx4))
981 (label-else-join
982 (context-last-label ctx5))
983 (ctx6
984 (context-make-label ctx5))
985 (label-join
986 (context-last-label ctx6))
987 (ctx7
988 (comp-test (child1 node) label-then label-else ctx6))
989 (ctx8
990 (gen-goto
991 label-else-join
992 (comp-none (child3 node)
993 (context-change-env2
994 (context-add-bb ctx7 label-else)
995 #f))))
996 (ctx9
997 (gen-goto
998 label-then-join
999 (comp-none (child2 node)
1000 (context-change-env
1001 (context-add-bb ctx8 label-then)
1002 (context-env2 ctx7)))))
1003 (ctx10
1004 (gen-goto
1005 label-join
1006 (context-add-bb ctx9 label-else-join)))
1007 (ctx11
1008 (gen-goto
1009 label-join
1010 (context-add-bb ctx10 label-then-join)))
1011 (ctx12
1012 (context-add-bb ctx11 label-join)))
1013 ctx12))
1015 ((call? node)
1016 (comp-call node 'none ctx))
1018 ((seq? node)
1019 (let ((children (node-children node)))
1020 (if (null? children)
1021 ctx
1022 (let loop ((lst children)
1023 (ctx ctx))
1024 (if (null? (cdr lst))
1025 (comp-none (car lst) ctx)
1026 (loop (cdr lst)
1027 (comp-none (car lst) ctx)))))))
1029 (else
1030 (compiler-error "unknown expression type" node)))))
1032 (define comp-tail
1033 (lambda (node ctx)
1035 (cond ((or (cst? node)
1036 (ref? node)
1037 (def? node)
1038 (set? node)
1039 (prc? node)
1040 ; (call? node)
1041 )
1042 (gen-return (comp-push node ctx)))
1044 ((if? node)
1045 (let* ((ctx2
1046 (context-make-label ctx))
1047 (label-then
1048 (context-last-label ctx2))
1049 (ctx3
1050 (context-make-label ctx2))
1051 (label-else
1052 (context-last-label ctx3))
1053 (ctx4
1054 (comp-test (child1 node) label-then label-else ctx3))
1055 (ctx5
1056 (comp-tail (child3 node)
1057 (context-change-env2
1058 (context-add-bb ctx4 label-else)
1059 #f)))
1060 (ctx6
1061 (comp-tail (child2 node)
1062 (context-change-env
1063 (context-add-bb ctx5 label-then)
1064 (context-env2 ctx4)))))
1065 ctx6))
1067 ((call? node)
1068 (comp-call node 'tail ctx))
1070 ((seq? node)
1071 (let ((children (node-children node)))
1072 (if (null? children)
1073 (gen-return (gen-push-unspecified ctx))
1074 (let loop ((lst children)
1075 (ctx ctx))
1076 (if (null? (cdr lst))
1077 (comp-tail (car lst) ctx)
1078 (loop (cdr lst)
1079 (comp-none (car lst) ctx)))))))
1081 (else
1082 (compiler-error "unknown expression type" node)))))
1084 (define comp-push
1085 (lambda (node ctx)
1087 '(
1088 (display "--------------\n")
1089 (pp (node->expr node))
1090 (pp env)
1091 (pp stk)
1092 )
1094 (cond ((cst? node)
1095 (let ((val (cst-val node)))
1096 (gen-push-constant val ctx)))
1098 ((ref? node)
1099 (let ((var (ref-var node)))
1100 (if (var-global? var)
1101 (if (null? (var-defs var))
1102 (compiler-error "undefined variable:" (var-id var))
1103 (let ((val (child1 (car (var-defs var)))))
1104 (if (and (not (mutable-var? var))
1105 (cst? val)) ;; immutable global, counted as cst
1106 (gen-push-constant (cst-val val) ctx)
1107 (gen-push-global (var-id var) ctx))))
1108 (gen-push-local-var (var-id var) ctx)))) ;; TODO globals as csts seem to work (but only for constant-values ones, like it probably should)
1110 ((or (def? node)
1111 (set? node))
1112 (gen-push-unspecified (comp-none node ctx)))
1114 ((if? node)
1115 (let* ((ctx2
1116 (context-make-label ctx))
1117 (label-then
1118 (context-last-label ctx2))
1119 (ctx3
1120 (context-make-label ctx2))
1121 (label-else
1122 (context-last-label ctx3))
1123 (ctx4
1124 (context-make-label ctx3))
1125 (label-then-join
1126 (context-last-label ctx4))
1127 (ctx5
1128 (context-make-label ctx4))
1129 (label-else-join
1130 (context-last-label ctx5))
1131 (ctx6
1132 (context-make-label ctx5))
1133 (label-join
1134 (context-last-label ctx6))
1135 (ctx7
1136 (comp-test (child1 node) label-then label-else ctx6))
1137 (ctx8
1138 (gen-goto
1139 label-else-join
1140 (comp-push (child3 node)
1141 (context-change-env2
1142 (context-add-bb ctx7 label-else)
1143 #f))))
1144 (ctx9
1145 (gen-goto
1146 label-then-join
1147 (comp-push (child2 node)
1148 (context-change-env
1149 (context-add-bb ctx8 label-then)
1150 (context-env2 ctx7)))))
1151 (ctx10
1152 (gen-goto
1153 label-join
1154 (context-add-bb ctx9 label-else-join)))
1155 (ctx11
1156 (gen-goto
1157 label-join
1158 (context-add-bb ctx10 label-then-join)))
1159 (ctx12
1160 (context-add-bb ctx11 label-join)))
1161 ctx12))
1163 ((prc? node)
1164 (comp-prc node #t ctx))
1166 ((call? node)
1167 (comp-call node 'push ctx))
1169 ((seq? node)
1170 (let ((children (node-children node)))
1171 (if (null? children)
1172 (gen-push-unspecified ctx)
1173 (let loop ((lst children)
1174 (ctx ctx))
1175 (if (null? (cdr lst))
1176 (comp-push (car lst) ctx)
1177 (loop (cdr lst)
1178 (comp-none (car lst) ctx)))))))
1180 (else
1181 (compiler-error "unknown expression type" node)))))
1183 (define (build-closure label-entry vars ctx)
1185 (define (build vars ctx)
1186 (if (null? vars)
1187 (gen-push-constant '() ctx)
1188 (gen-prim '#%cons
1189 2
1190 #f
1191 (build (cdr vars)
1192 (gen-push-local-var (car vars) ctx)))))
1194 (if (null? vars)
1195 (gen-closure label-entry
1196 (gen-push-constant '() ctx))
1197 (gen-closure label-entry
1198 (build vars ctx))))
1199 ;; TODO the last branch was changed because since pointers are now larger, there is not a pointer-sized free space in each closure, which could make it behave like a pair. now, everything is in the env, and closures only have a cdr
1201 (define comp-prc
1202 (lambda (node closure? ctx)
1203 (let* ((ctx2
1204 (context-make-label ctx))
1205 (label-entry
1206 (context-last-label ctx2))
1207 (ctx3
1208 (context-make-label ctx2))
1209 (label-continue
1210 (context-last-label ctx3))
1211 (body-env
1212 (prc->env node))
1213 (ctx4
1214 (if closure?
1215 (build-closure label-entry (env-closed body-env) ctx3)
1216 ctx3))
1217 (ctx5
1218 (gen-goto label-continue ctx4))
1219 (ctx6
1220 (gen-entry (length (prc-params node))
1221 (prc-rest? node)
1222 (context-add-bb (context-change-env ctx5
1223 body-env)
1224 label-entry)))
1225 (ctx7
1226 (comp-tail (child1 node) ctx6)))
1227 (prc-entry-label-set! node label-entry)
1228 (context-add-bb (context-change-env ctx7 (context-env ctx5))
1229 label-continue))))
1231 (define comp-call
1232 (lambda (node reason ctx)
1233 (let* ((op (child1 node))
1234 (args (cdr (node-children node)))
1235 (nargs (length args)))
1236 (let loop ((lst args)
1237 (ctx ctx))
1238 (if (pair? lst)
1240 (let ((arg (car lst)))
1241 (loop (cdr lst)
1242 (comp-push arg ctx)))
1244 (cond ((and (ref? op)
1245 (var-primitive (ref-var op)))
1246 (let* ((var (ref-var op))
1247 (id (var-id var))
1248 (primitive (var-primitive var))
1249 (prim-nargs (primitive-nargs primitive)))
1251 (define use-result
1252 (lambda (ctx2)
1253 (cond ((eq? reason 'tail)
1254 (gen-return
1255 (if (primitive-unspecified-result? primitive)
1256 (gen-push-unspecified ctx2)
1257 ctx2)))
1258 ((eq? reason 'push)
1259 (if (primitive-unspecified-result? primitive)
1260 (gen-push-unspecified ctx2)
1261 ctx2))
1262 (else
1263 (if (primitive-unspecified-result? primitive)
1264 ctx2
1265 (gen-pop ctx2))))))
1267 (use-result
1268 (if (primitive-inliner primitive)
1269 ((primitive-inliner primitive) ctx)
1270 (if (not (= nargs prim-nargs))
1271 (compiler-error "primitive called with wrong number of arguments" id)
1272 (gen-prim
1273 id
1274 prim-nargs
1275 (primitive-unspecified-result? primitive)
1276 ctx))))))
1279 ((and (ref? op)
1280 (toplevel-prc-with-non-rest-correct-calls? (ref-var op)))
1281 =>
1282 (lambda (prc)
1283 (cond ((eq? reason 'tail)
1284 (gen-jump-toplevel nargs prc ctx))
1285 ((eq? reason 'push)
1286 (gen-call-toplevel nargs prc ctx))
1287 (else
1288 (gen-pop (gen-call-toplevel nargs prc ctx))))))
1290 (else
1291 (let ((ctx2 (comp-push op ctx)))
1292 (cond ((eq? reason 'tail)
1293 (gen-jump nargs ctx2))
1294 ((eq? reason 'push)
1295 (gen-call nargs ctx2))
1296 (else
1297 (gen-pop (gen-call nargs ctx2))))))))))))
1299 (define comp-test
1300 (lambda (node label-true label-false ctx)
1301 (cond ((cst? node)
1302 (let ((ctx2
1303 (gen-goto
1304 (let ((val (cst-val node)))
1305 (if val
1306 label-true
1307 label-false))
1308 ctx)))
1309 (context-change-env2 ctx2 (context-env ctx2))))
1311 ((or (ref? node)
1312 (def? node)
1313 (set? node)
1314 (if? node)
1315 (call? node)
1316 (seq? node))
1317 (let* ((ctx2
1318 (comp-push node ctx))
1319 (ctx3
1320 (gen-goto-if-false label-false label-true ctx2)))
1321 (context-change-env2 ctx3 (context-env ctx3))))
1323 ((prc? node)
1324 (let ((ctx2
1325 (gen-goto label-true ctx)))
1326 (context-change-env2 ctx2 (context-env ctx2))))
1328 (else
1329 (compiler-error "unknown expression type" node)))))
1331 ;-----------------------------------------------------------------------------
1333 (define toplevel-prc?
1334 (lambda (var)
1335 (and (not (mutable-var? var))
1336 (let ((d (var-defs var)))
1337 (and (pair? d)
1338 (null? (cdr d))
1339 (let ((val (child1 (car d))))
1340 (and (prc? val)
1341 val)))))))
1343 (define toplevel-prc-with-non-rest-correct-calls?
1344 (lambda (var)
1345 (let ((prc (toplevel-prc? var)))
1346 (and prc
1347 (not (prc-rest? prc))
1348 (every (lambda (r)
1349 (let ((parent (node-parent r)))
1350 (and (call? parent)
1351 (eq? (child1 parent) r)
1352 (= (length (prc-params prc))
1353 (- (length (node-children parent)) 1)))))
1354 (var-refs var))
1355 prc))))
1357 (define mutable-var?
1358 (lambda (var)
1359 (not (null? (var-sets var)))))
1361 (define global-fv
1362 (lambda (node)
1363 (list->varset
1364 (keep var-global?
1365 (varset->list (fv node))))))
1367 (define non-global-fv
1368 (lambda (node)
1369 (list->varset
1370 (keep (lambda (x) (not (var-global? x)))
1371 (varset->list (fv node))))))
1373 (define fv
1374 (lambda (node)
1375 (cond ((cst? node)
1376 (varset-empty))
1377 ((ref? node)
1378 (let ((var (ref-var node)))
1379 (varset-singleton var)))
1380 ((def? node)
1381 (let ((var (def-var node))
1382 (val (child1 node)))
1383 (varset-union
1384 (varset-singleton var)
1385 (fv val))))
1386 ((set? node)
1387 (let ((var (set-var node))
1388 (val (child1 node)))
1389 (varset-union
1390 (varset-singleton var)
1391 (fv val))))
1392 ((if? node)
1393 (let ((a (list-ref (node-children node) 0))
1394 (b (list-ref (node-children node) 1))
1395 (c (list-ref (node-children node) 2)))
1396 (varset-union-multi (list (fv a) (fv b) (fv c)))))
1397 ((prc? node)
1398 (let ((body (list-ref (node-children node) 0)))
1399 (varset-difference
1400 (fv body)
1401 (build-params-varset (prc-params node)))))
1402 ((call? node)
1403 (varset-union-multi (map fv (node-children node))))
1404 ((seq? node)
1405 (varset-union-multi (map fv (node-children node))))
1406 (else
1407 (compiler-error "unknown expression type" node)))))
1409 (define build-params-varset
1410 (lambda (params)
1411 (list->varset params)))
1413 (define mark-needed-global-vars!
1414 (lambda (global-env node)
1416 (define readyq
1417 (env-lookup global-env '#%readyq))
1419 (define mark-var!
1420 (lambda (var)
1421 (if (and (var-global? var)
1422 (not (var-needed? var))
1423 ;; globals that obey the following conditions are considered
1424 ;; to be constants
1425 (not (and (not (mutable-var? var))
1426 (> (length (var-defs var)) 0) ;; TODO to catch errors for primitives
1427 (cst? (child1 (car (var-defs var)))))))
1428 (begin
1429 (var-needed?-set! var #t)
1430 (for-each
1431 (lambda (def)
1432 (let ((val (child1 def)))
1433 (if (side-effect-less? val)
1434 (mark! val))))
1435 (var-defs var))
1436 (if (eq? var readyq)
1437 (begin
1438 (mark-var!
1439 (env-lookup global-env '#%start-first-process))
1440 (mark-var!
1441 (env-lookup global-env '#%exit))))))))
1443 (define side-effect-less?
1444 (lambda (node)
1445 (or (cst? node)
1446 (ref? node)
1447 (prc? node))))
1449 (define mark!
1450 (lambda (node)
1451 (cond ((cst? node))
1452 ((ref? node)
1453 (let ((var (ref-var node)))
1454 (mark-var! var)))
1455 ((def? node)
1456 (let ((var (def-var node))
1457 (val (child1 node)))
1458 (if (not (side-effect-less? val))
1459 (mark! val))))
1460 ((set? node)
1461 (let ((var (set-var node))
1462 (val (child1 node)))
1463 (mark! val)))
1464 ((if? node)
1465 (let ((a (list-ref (node-children node) 0))
1466 (b (list-ref (node-children node) 1))
1467 (c (list-ref (node-children node) 2)))
1468 (mark! a)
1469 (mark! b)
1470 (mark! c)))
1471 ((prc? node)
1472 (let ((body (list-ref (node-children node) 0)))
1473 (mark! body)))
1474 ((call? node)
1475 (for-each mark! (node-children node)))
1476 ((seq? node)
1477 (for-each mark! (node-children node)))
1478 (else
1479 (compiler-error "unknown expression type" node)))))
1481 (mark! node)
1482 ))
1484 ;-----------------------------------------------------------------------------
1486 ;; Variable sets
1488 (define (varset-empty) ; return the empty set
1489 '())
1491 (define (varset-singleton x) ; create a set containing only 'x'
1492 (list x))
1494 (define (list->varset lst) ; convert list to set
1495 lst)
1497 (define (varset->list set) ; convert set to list
1498 set)
1500 (define (varset-size set) ; return cardinality of set
1501 (list-length set))
1503 (define (varset-empty? set) ; is 'x' the empty set?
1504 (null? set))
1506 (define (varset-member? x set) ; is 'x' a member of the 'set'?
1507 (and (not (null? set))
1508 (or (eq? x (car set))
1509 (varset-member? x (cdr set)))))
1511 (define (varset-adjoin set x) ; add the element 'x' to the 'set'
1512 (if (varset-member? x set) set (cons x set)))
1514 (define (varset-remove set x) ; remove the element 'x' from 'set'
1515 (cond ((null? set)
1516 '())
1517 ((eq? (car set) x)
1518 (cdr set))
1519 (else
1520 (cons (car set) (varset-remove (cdr set) x)))))
1522 (define (varset-equal? s1 s2) ; are 's1' and 's2' equal sets?
1523 (and (varset-subset? s1 s2)
1524 (varset-subset? s2 s1)))
1526 (define (varset-subset? s1 s2) ; is 's1' a subset of 's2'?
1527 (cond ((null? s1)
1528 #t)
1529 ((varset-member? (car s1) s2)
1530 (varset-subset? (cdr s1) s2))
1531 (else
1532 #f)))
1534 (define (varset-difference set1 set2) ; return difference of sets
1535 (cond ((null? set1)
1536 '())
1537 ((varset-member? (car set1) set2)
1538 (varset-difference (cdr set1) set2))
1539 (else
1540 (cons (car set1) (varset-difference (cdr set1) set2)))))
1542 (define (varset-union set1 set2) ; return union of sets
1543 (define (union s1 s2)
1544 (cond ((null? s1)
1545 s2)
1546 ((varset-member? (car s1) s2)
1547 (union (cdr s1) s2))
1548 (else
1549 (cons (car s1) (union (cdr s1) s2)))))
1550 (if (varset-smaller? set1 set2)
1551 (union set1 set2)
1552 (union set2 set1)))
1554 (define (varset-intersection set1 set2) ; return intersection of sets
1555 (define (intersection s1 s2)
1556 (cond ((null? s1)
1557 '())
1558 ((varset-member? (car s1) s2)
1559 (cons (car s1) (intersection (cdr s1) s2)))
1560 (else
1561 (intersection (cdr s1) s2))))
1562 (if (varset-smaller? set1 set2)
1563 (intersection set1 set2)
1564 (intersection set2 set1)))
1566 (define (varset-intersects? set1 set2) ; do sets 'set1' and 'set2' intersect?
1567 (not (varset-empty? (varset-intersection set1 set2))))
1569 (define (varset-smaller? set1 set2)
1570 (if (null? set1)
1571 (not (null? set2))
1572 (if (null? set2)
1573 #f
1574 (varset-smaller? (cdr set1) (cdr set2)))))
1576 (define (varset-union-multi sets)
1577 (if (null? sets)
1578 (varset-empty)
1579 (n-ary varset-union (car sets) (cdr sets))))
1581 (define (n-ary function first rest)
1582 (if (null? rest)
1583 first
1584 (n-ary function (function first (car rest)) (cdr rest))))
1586 ;------------------------------------------------------------------------------
1588 (define code->vector
1589 (lambda (code)
1590 (let ((v (make-vector (+ (code-last-label code) 1))))
1591 (for-each
1592 (lambda (bb)
1593 (vector-set! v (bb-label bb) bb))
1594 (code-rev-bbs code))
1595 v)))
1597 (define bbs->ref-counts
1598 (lambda (bbs)
1599 (let ((ref-counts (make-vector (vector-length bbs) 0)))
1601 (define visit
1602 (lambda (label)
1603 (let ((ref-count (vector-ref ref-counts label)))
1604 (vector-set! ref-counts label (+ ref-count 1))
1605 (if (= ref-count 0)
1606 (let* ((bb (vector-ref bbs label))
1607 (rev-instrs (bb-rev-instrs bb)))
1608 (for-each
1609 (lambda (instr)
1610 (let ((opcode (car instr)))
1611 (cond ((eq? opcode 'goto)
1612 (visit (cadr instr)))
1613 ((eq? opcode 'goto-if-false)
1614 (visit (cadr instr))
1615 (visit (caddr instr)))
1616 ((or (eq? opcode 'closure)
1617 (eq? opcode 'call-toplevel)
1618 (eq? opcode 'jump-toplevel))
1619 (visit (cadr instr))))))
1620 rev-instrs))))))
1622 (visit 0)
1624 ref-counts)))
1626 (define resolve-toplevel-labels!
1627 (lambda (bbs)
1628 (let loop ((i 0))
1629 (if (< i (vector-length bbs))
1630 (let* ((bb (vector-ref bbs i))
1631 (rev-instrs (bb-rev-instrs bb)))
1632 (bb-rev-instrs-set!
1633 bb
1634 (map (lambda (instr)
1635 (let ((opcode (car instr)))
1636 (cond ((eq? opcode 'call-toplevel)
1637 (list opcode
1638 (prc-entry-label (cadr instr))))
1639 ((eq? opcode 'jump-toplevel)
1640 (list opcode
1641 (prc-entry-label (cadr instr))))
1642 (else
1643 instr))))
1644 rev-instrs))
1645 (loop (+ i 1)))))))
1647 (define tighten-jump-cascades!
1648 (lambda (bbs)
1649 (let ((ref-counts (bbs->ref-counts bbs)))
1651 (define resolve
1652 (lambda (label)
1653 (let* ((bb (vector-ref bbs label))
1654 (rev-instrs (bb-rev-instrs bb)))
1655 (and (or (null? (cdr rev-instrs))
1656 (= (vector-ref ref-counts label) 1))
1657 rev-instrs))))
1659 (let loop1 ()
1660 (let loop2 ((i 0)
1661 (changed? #f))
1662 (if (< i (vector-length bbs))
1663 (if (> (vector-ref ref-counts i) 0)
1664 (let* ((bb (vector-ref bbs i))
1665 (rev-instrs (bb-rev-instrs bb))
1666 (jump (car rev-instrs))
1667 (opcode (car jump)))
1668 (cond ((eq? opcode 'goto)
1669 (let* ((label (cadr jump))
1670 (jump-replacement (resolve label)))
1671 (if jump-replacement
1672 (begin
1673 (vector-set!
1674 bbs
1675 i
1676 (make-bb (bb-label bb)
1677 (append jump-replacement
1678 (cdr rev-instrs))))
1679 (loop2 (+ i 1)
1680 #t))
1681 (loop2 (+ i 1)
1682 changed?))))
1683 ((eq? opcode 'goto-if-false)
1684 (let* ((label-then (cadr jump))
1685 (label-else (caddr jump))
1686 (jump-then-replacement (resolve label-then))
1687 (jump-else-replacement (resolve label-else)))
1688 (if (and jump-then-replacement
1689 (null? (cdr jump-then-replacement))
1690 jump-else-replacement
1691 (null? (cdr jump-else-replacement))
1692 (or (eq? (caar jump-then-replacement)
1693 'goto)
1694 (eq? (caar jump-else-replacement)
1695 'goto)))
1696 (begin
1697 (vector-set!
1698 bbs
1699 i
1700 (make-bb
1701 (bb-label bb)
1702 (cons
1703 (list
1704 'goto-if-false
1705 (if (eq? (caar jump-then-replacement)
1706 'goto)
1707 (cadar jump-then-replacement)
1708 label-then)
1709 (if (eq? (caar jump-else-replacement)
1710 'goto)
1711 (cadar jump-else-replacement)
1712 label-else))
1713 (cdr rev-instrs))))
1714 (loop2 (+ i 1)
1715 #t))
1716 (loop2 (+ i 1)
1717 changed?))))
1718 (else
1719 (loop2 (+ i 1)
1720 changed?))))
1721 (loop2 (+ i 1)
1722 changed?))
1723 (if changed?
1724 (loop1))))))))
1726 (define remove-useless-bbs!
1727 (lambda (bbs)
1728 (let ((ref-counts (bbs->ref-counts bbs)))
1729 (let loop1 ((label 0) (new-label 0))
1730 (if (< label (vector-length bbs))
1731 (if (> (vector-ref ref-counts label) 0)
1732 (let ((bb (vector-ref bbs label)))
1733 (vector-set!
1734 bbs
1735 label
1736 (make-bb new-label (bb-rev-instrs bb)))
1737 (loop1 (+ label 1) (+ new-label 1)))
1738 (loop1 (+ label 1) new-label))
1739 (renumber-labels bbs ref-counts new-label))))))
1741 (define renumber-labels
1742 (lambda (bbs ref-counts n)
1743 (let ((new-bbs (make-vector n)))
1744 (let loop2 ((label 0))
1745 (if (< label (vector-length bbs))
1746 (if (> (vector-ref ref-counts label) 0)
1747 (let* ((bb (vector-ref bbs label))
1748 (new-label (bb-label bb))
1749 (rev-instrs (bb-rev-instrs bb)))
1751 (define fix
1752 (lambda (instr)
1754 (define new-label
1755 (lambda (label)
1756 (bb-label (vector-ref bbs label))))
1758 (let ((opcode (car instr)))
1759 (cond ((eq? opcode 'closure)
1760 (list 'closure
1761 (new-label (cadr instr))))
1762 ((eq? opcode 'call-toplevel)
1763 (list 'call-toplevel
1764 (new-label (cadr instr))))
1765 ((eq? opcode 'jump-toplevel)
1766 (list 'jump-toplevel
1767 (new-label (cadr instr))))
1768 ((eq? opcode 'goto)
1769 (list 'goto
1770 (new-label (cadr instr))))
1771 ((eq? opcode 'goto-if-false)
1772 (list 'goto-if-false
1773 (new-label (cadr instr))
1774 (new-label (caddr instr))))
1775 (else
1776 instr)))))
1778 (vector-set!
1779 new-bbs
1780 new-label
1781 (make-bb new-label (map fix rev-instrs)))
1782 (loop2 (+ label 1)))
1783 (loop2 (+ label 1)))
1784 new-bbs)))))
1786 (define reorder!
1787 (lambda (bbs)
1788 (let* ((done (make-vector (vector-length bbs) #f)))
1790 (define unscheduled?
1791 (lambda (label)
1792 (not (vector-ref done label))))
1794 (define label-refs
1795 (lambda (instrs todo)
1796 (if (pair? instrs)
1797 (let* ((instr (car instrs))
1798 (opcode (car instr)))
1799 (cond ((or (eq? opcode 'closure)
1800 (eq? opcode 'call-toplevel)
1801 (eq? opcode 'jump-toplevel))
1802 (label-refs (cdr instrs) (cons (cadr instr) todo)))
1803 (else
1804 (label-refs (cdr instrs) todo))))
1805 todo)))
1807 (define schedule-here
1808 (lambda (label new-label todo cont)
1809 (let* ((bb (vector-ref bbs label))
1810 (rev-instrs (bb-rev-instrs bb))
1811 (jump (car rev-instrs))
1812 (opcode (car jump))
1813 (new-todo (label-refs rev-instrs todo)))
1814 (vector-set! bbs label (make-bb new-label rev-instrs))
1815 (vector-set! done label #t)
1816 (cond ((eq? opcode 'goto)
1817 (let ((label (cadr jump)))
1818 (if (unscheduled? label)
1819 (schedule-here label
1820 (+ new-label 1)
1821 new-todo
1822 cont)
1823 (cont (+ new-label 1)
1824 new-todo))))
1825 ((eq? opcode 'goto-if-false)
1826 (let ((label-then (cadr jump))
1827 (label-else (caddr jump)))
1828 (cond ((unscheduled? label-else)
1829 (schedule-here label-else
1830 (+ new-label 1)
1831 (cons label-then new-todo)
1832 cont))
1833 ((unscheduled? label-then)
1834 (schedule-here label-then
1835 (+ new-label 1)
1836 new-todo
1837 cont))
1838 (else
1839 (cont (+ new-label 1)
1840 new-todo)))))
1841 (else
1842 (cont (+ new-label 1)
1843 new-todo))))))
1845 (define schedule-somewhere
1846 (lambda (label new-label todo cont)
1847 (schedule-here label new-label todo cont)))
1849 (define schedule-todo
1850 (lambda (new-label todo)
1851 (if (pair? todo)
1852 (let ((label (car todo)))
1853 (if (unscheduled? label)
1854 (schedule-somewhere label
1855 new-label
1856 (cdr todo)
1857 schedule-todo)
1858 (schedule-todo new-label
1859 (cdr todo)))))))
1862 (schedule-here 0 0 '() schedule-todo)
1864 (renumber-labels bbs
1865 (make-vector (vector-length bbs) 1)
1866 (vector-length bbs)))))
1868 (define linearize
1869 (lambda (bbs)
1870 (let loop ((label (- (vector-length bbs) 1))
1871 (lst '()))
1872 (if (>= label 0)
1873 (let* ((bb (vector-ref bbs label))
1874 (rev-instrs (bb-rev-instrs bb))
1875 (jump (car rev-instrs))
1876 (opcode (car jump)))
1877 (loop (- label 1)
1878 (append
1879 (list label)
1880 (reverse
1881 (cond ((eq? opcode 'goto)
1882 (if (= (cadr jump) (+ label 1))
1883 (cdr rev-instrs)
1884 rev-instrs))
1885 ((eq? opcode 'goto-if-false)
1886 (cond ((= (caddr jump) (+ label 1))
1887 (cons (list 'goto-if-false (cadr jump))
1888 (cdr rev-instrs)))
1889 ((= (cadr jump) (+ label 1))
1890 (cons (list 'goto-if-not-false (caddr jump))
1891 (cdr rev-instrs)))
1892 (else
1893 (cons (list 'goto (caddr jump))
1894 (cons (list 'goto-if-false (cadr jump))
1895 (cdr rev-instrs))))))
1896 (else
1897 rev-instrs)))
1898 lst)))
1899 lst))))
1901 (define optimize-code
1902 (lambda (code)
1903 (let ((bbs (code->vector code)))
1904 (resolve-toplevel-labels! bbs)
1905 (tighten-jump-cascades! bbs)
1906 (let ((bbs (remove-useless-bbs! bbs)))
1907 (reorder! bbs)))))
1910 (define expand-includes
1911 (lambda (exprs)
1912 (map (lambda (e)
1913 (if (eq? (car e) 'include)
1914 (cons 'begin
1915 (expand-includes
1916 (with-input-from-file (cadr e) read-all)))
1917 e))
1918 exprs)))
1920 (define parse-file
1921 (lambda (filename)
1922 (let* ((library
1923 (with-input-from-file "library.scm" read-all))
1924 (toplevel-exprs
1925 (expand-includes
1926 (append library
1927 (with-input-from-file filename read-all))))
1928 (global-env
1929 (make-global-env))
1930 (parsed-prog
1931 (parse-top (cons 'begin toplevel-exprs) global-env)))
1933 (for-each
1934 (lambda (node)
1935 (mark-needed-global-vars! global-env node))
1936 parsed-prog)
1938 (extract-parts
1939 parsed-prog
1940 (lambda (defs after-defs)
1942 (define make-seq-preparsed
1943 (lambda (exprs)
1944 (let ((r (make-seq #f exprs)))
1945 (for-each (lambda (x) (node-parent-set! x r)) exprs)
1946 r)))
1948 (define make-call-preparsed
1949 (lambda (exprs)
1950 (let ((r (make-call #f exprs)))
1951 (for-each (lambda (x) (node-parent-set! x r)) exprs)
1952 r)))
1954 (if (var-needed?
1955 (env-lookup global-env '#%readyq))
1956 (make-seq-preparsed
1957 (list (make-seq-preparsed defs)
1958 (make-call-preparsed
1959 (list (parse 'value '#%start-first-process global-env)
1960 (let* ((pattern
1961 '())
1962 (ids
1963 (extract-ids pattern))
1964 (r
1965 (make-prc #f
1966 '()
1967 #f
1968 (has-rest-param? pattern)
1969 #f))
1970 (new-env
1971 (env-extend global-env ids r))
1972 (body
1973 (make-seq-preparsed after-defs)))
1974 (prc-params-set!
1975 r
1976 (map (lambda (id) (env-lookup new-env id))
1977 ids))
1978 (node-children-set! r (list body))
1979 (node-parent-set! body r)
1980 r)))
1981 (parse 'value
1982 '(#%exit)
1983 global-env)))
1984 (make-seq-preparsed
1985 (append defs
1986 after-defs
1987 (list (parse 'value
1988 '(#%halt)
1989 global-env))))))))))
1991 (define extract-parts
1992 (lambda (lst cont)
1993 (if (or (null? lst)
1994 (not (def? (car lst))))
1995 (cont '() lst)
1996 (extract-parts
1997 (cdr lst)
1998 (lambda (d ad)
1999 (cont (cons (car lst) d) ad))))))
2001 ;------------------------------------------------------------------------------
2003 ;;(include "asm.scm")
2005 ;;; File: "asm.scm"
2006 ;;;
2007 ;;; This module implements the generic assembler.
2009 ;;(##declare (standard-bindings) (fixnum) (block))
2011 (define compiler-internal-error error)
2013 ;; (asm-begin! start-pos big-endian?) initializes the assembler and
2014 ;; starts a new empty code stream at address "start-pos". It must be
2015 ;; called every time a new code stream is to be built. The argument
2016 ;; "big-endian?" indicates the byte ordering to use for 16, 32 and 64
2017 ;; bit values. After a call to "asm-begin!" the code stream is built
2018 ;; by calling the following procedures:
2019 ;;
2020 ;; asm-8 to add an 8 bit integer to the code stream
2021 ;; asm-16 to add a 16 bit integer to the code stream
2022 ;; asm-32 to add a 32 bit integer to the code stream
2023 ;; asm-64 to add a 64 bit integer to the code stream
2024 ;; asm-float64 to add a 64 bit IEEE float to the code stream
2025 ;; asm-string to add a null terminated string to the code stream
2026 ;; asm-label to set a label to the current position in the code stream
2027 ;; asm-align to add enough zero bytes to force alignment
2028 ;; asm-origin to add enough zero bytes to move to a particular address
2029 ;; asm-at-assembly to defer code production to assembly time
2030 ;; asm-listing to add textual information to the listing
2032 (define (asm-begin! start-pos big-endian?)
2033 (set! asm-start-pos start-pos)
2034 (set! asm-big-endian? big-endian?)
2035 (set! asm-code-stream (asm-make-stream))
2036 #f)
2038 ;; (asm-end!) must be called to finalize the assembler.
2040 (define (asm-end!)
2041 (set! asm-code-stream #f)
2042 #f)
2044 ;; (asm-8 n) adds an 8 bit signed or unsigned integer to the code stream.
2046 (define (asm-8 n)
2047 (asm-code-extend (asm-bits-0-to-7 n)))
2049 ;; (asm-16 n) adds a 16 bit signed or unsigned integer to the code stream.
2051 (define (asm-16 n)
2052 (if asm-big-endian?
2053 (begin (asm-8 (asm-bits-8-and-up n)) (asm-8 n))
2054 (begin (asm-8 n) (asm-8 (asm-bits-8-and-up n)))))
2056 ;; (asm-32 n) adds a 32 bit signed or unsigned integer to the code stream.
2058 (define (asm-32 n)
2059 (if asm-big-endian?
2060 (begin (asm-16 (asm-bits-16-and-up n)) (asm-16 n))
2061 (begin (asm-16 n) (asm-16 (asm-bits-16-and-up n)))))
2063 ;; (asm-64 n) adds a 64 bit signed or unsigned integer to the code stream.
2065 (define (asm-64 n)
2066 (if asm-big-endian?
2067 (begin (asm-32 (asm-bits-32-and-up n)) (asm-32 n))
2068 (begin (asm-32 n) (asm-32 (asm-bits-32-and-up n)))))
2070 ;; (asm-float64 n) adds a 64 bit IEEE floating point number to the code stream.
2072 (define (asm-float64 n)
2073 (asm-64 (asm-float->bits n)))
2075 ;; (asm-string str) adds a null terminated string to the code stream.
2077 (define (asm-string str)
2078 (let ((len (string-length str)))
2079 (let loop ((i 0))
2080 (if (< i len)
2081 (begin
2082 (asm-8 (char->integer (string-ref str i)))
2083 (loop (+ i 1)))
2084 (asm-8 0)))))
2086 ;; (asm-make-label id) creates a new label object. A label can
2087 ;; be queried with "asm-label-pos" to obtain the label's position
2088 ;; relative to the start of the code stream (i.e. "start-pos").
2089 ;; The argument "id" gives a name to the label (not necessarily
2090 ;; unique) and is only needed for debugging purposes.
2092 (define (asm-make-label id)
2093 (vector 'LABEL #f id))
2095 ;; (asm-label label-obj) sets the label to the current position in the
2096 ;; code stream.
2098 (define (asm-label label-obj)
2099 (if (vector-ref label-obj 1)
2100 (compiler-internal-error
2101 "asm-label, label multiply defined" (asm-label-id label-obj))
2102 (begin
2103 (vector-set! label-obj 1 0)
2104 (asm-code-extend label-obj))))
2106 ;; (asm-label-id label-obj) returns the identifier of the label object.
2108 (define (asm-label-id label-obj)
2109 (vector-ref label-obj 2))
2111 ;; (asm-label-pos label-obj) returns the position of the label
2112 ;; relative to the start of the code stream (i.e. "start-pos").
2113 ;; This procedure can only be called at assembly time (i.e.
2114 ;; within the call to "asm-assemble") or after assembly time
2115 ;; for labels declared prior to assembly time with "asm-label".
2116 ;; A label declared at assembly time can only be queried after
2117 ;; assembly time. Moreover, at assembly time the position of a
2118 ;; label may vary from one call to the next due to the actions
2119 ;; of the assembler.
2121 (define (asm-label-pos label-obj)
2122 (let ((pos (vector-ref label-obj 1)))
2123 (if pos
2124 pos
2125 (compiler-internal-error
2126 "asm-label-pos, undefined label" (asm-label-id label-obj)))))
2128 ;; (asm-align multiple offset) adds enough zero bytes to the code
2129 ;; stream to force alignment to the next address congruent to
2130 ;; "offset" modulo "multiple".
2132 (define (asm-align multiple offset)
2133 (asm-at-assembly
2134 (lambda (self)
2135 (modulo (- multiple (- self offset)) multiple))
2136 (lambda (self)
2137 (let loop ((n (modulo (- multiple (- self offset)) multiple)))
2138 (if (> n 0)
2139 (begin
2140 (asm-8 0)
2141 (loop (- n 1))))))))
2143 ;; (asm-origin address) adds enough zero bytes to the code stream to move
2144 ;; to the address "address".
2146 (define (asm-origin address)
2147 (asm-at-assembly
2148 (lambda (self)
2149 (- address self))
2150 (lambda (self)
2151 (let ((len (- address self)))
2152 (if (< len 0)
2153 (compiler-internal-error "asm-origin, can't move back")
2154 (let loop ((n len))
2155 (if (> n 0)
2156 (begin
2157 (asm-8 0)
2158 (loop (- n 1))))))))))
2160 ;; (asm-at-assembly . procs) makes it possible to defer code
2161 ;; production to assembly time. A useful application is to generate
2162 ;; position dependent and span dependent code sequences. This
2163 ;; procedure must be passed an even number of procedures. All odd
2164 ;; indexed procedures (including the first procedure) are called "check"
2165 ;; procedures. The even indexed procedures are the "production"
2166 ;; procedures which, when called, produce a particular code sequence.
2167 ;; A check procedure decides if, given the current state of assembly
2168 ;; (in particular the current positioning of the labels), the code
2169 ;; produced by the corresponding production procedure is valid.
2170 ;; If the code is not valid, the check procedure must return #f.
2171 ;; If the code is valid, the check procedure must return the length
2172 ;; of the code sequence in bytes. The assembler will try each check
2173 ;; procedure in order until it finds one that does not return #f
2174 ;; (the last check procedure must never return #f). For convenience,
2175 ;; the current position in the code sequence is passed as the single
2176 ;; argument of check and production procedures.
2177 ;;
2178 ;; Here is a sample call of "asm-at-assembly" to produce the
2179 ;; shortest branch instruction to branch to label "x" for a
2180 ;; hypothetical processor:
2181 ;;
2182 ;; (asm-at-assembly
2183 ;;
2184 ;; (lambda (self) ; first check procedure
2185 ;; (let ((dist (- (asm-label-pos x) self)))
2186 ;; (if (and (>= dist -128) (<= dist 127)) ; short branch possible?
2187 ;; 2
2188 ;; #f)))
2189 ;;
2190 ;; (lambda (self) ; first production procedure
2191 ;; (asm-8 #x34) ; branch opcode for 8 bit displacement
2192 ;; (asm-8 (- (asm-label-pos x) self)))
2193 ;;
2194 ;; (lambda (self) 5) ; second check procedure
2195 ;;
2196 ;; (lambda (self) ; second production procedure
2197 ;; (asm-8 #x35) ; branch opcode for 32 bit displacement
2198 ;; (asm-32 (- (asm-label-pos x) self))))
2200 (define (asm-at-assembly . procs)
2201 (asm-code-extend (vector 'DEFERRED procs)))
2203 ;; (asm-listing text) adds text to the right side of the listing.
2204 ;; The atoms in "text" will be output using "display" (lists are
2205 ;; traversed recursively). The listing is generated by calling
2206 ;; "asm-display-listing".
2208 (define (asm-listing text)
2209 (asm-code-extend (vector 'LISTING text)))
2211 ;; (asm-assemble) assembles the code stream. After assembly, the
2212 ;; label objects will be set to their final position and the
2213 ;; alignment bytes and the deferred code will have been produced. It
2214 ;; is possible to extend the code stream after assembly. However, if
2215 ;; any of the procedures "asm-label", "asm-align", and
2216 ;; "asm-at-assembly" are called, the code stream will have to be
2217 ;; assembled once more.
2219 (define (asm-assemble)
2220 (let ((fixup-lst (asm-pass1)))
2222 (let loop1 ()
2223 (let loop2 ((lst fixup-lst)
2224 (changed? #f)
2225 (pos asm-start-pos))
2226 (if (null? lst)
2227 (if changed? (loop1))
2228 (let* ((fixup (car lst))
2229 (pos (+ pos (car fixup)))
2230 (curr (cdr fixup))
2231 (x (car curr)))
2232 (if (eq? (vector-ref x 0) 'LABEL)
2233 ; LABEL
2234 (if (= (vector-ref x 1) pos)
2235 (loop2 (cdr lst) changed? pos)
2236 (begin
2237 (vector-set! x 1 pos)
2238 (loop2 (cdr lst) #t pos)))
2239 ; DEFERRED
2240 (let loop3 ()
2241 (let ((n ((car (vector-ref x 1)) pos)))
2242 (if n
2243 (loop2 (cdr lst) changed? (+ pos n))
2244 (begin
2245 (vector-set! x 1 (cddr (vector-ref x 1)))
2246 (loop3))))))))))
2248 (let loop4 ((prev asm-code-stream)
2249 (curr (cdr asm-code-stream))
2250 (pos asm-start-pos))
2251 (if (null? curr)
2252 (set-car! asm-code-stream prev)
2253 (let ((x (car curr))
2254 (next (cdr curr)))
2255 (if (vector? x)
2256 (let ((kind (vector-ref x 0)))
2257 (cond ((eq? kind 'LABEL)
2258 (let ((final-pos (vector-ref x 1)))
2259 (if final-pos
2260 (if (not (= pos final-pos))
2261 (compiler-internal-error
2262 "asm-assemble, inconsistency detected"))
2263 (vector-set! x 1 pos))
2264 (set-cdr! prev next)
2265 (loop4 prev next pos)))
2266 ((eq? kind 'DEFERRED)
2267 (let ((temp asm-code-stream))
2268 (set! asm-code-stream (asm-make-stream))
2269 ((cadr (vector-ref x 1)) pos)
2270 (let ((tail (car asm-code-stream)))
2271 (set-cdr! tail next)
2272 (let ((head (cdr asm-code-stream)))
2273 (set-cdr! prev head)
2274 (set! asm-code-stream temp)
2275 (loop4 prev head pos)))))
2276 (else
2277 (loop4 curr next pos))))
2278 (loop4 curr next (+ pos 1))))))))
2280 ;; (asm-display-listing port) produces a listing of the code stream
2281 ;; on the given output port. The bytes generated are shown in
2282 ;; hexadecimal on the left side of the listing and the right side
2283 ;; of the listing contains the text inserted by "asm-listing".
2285 (define (asm-display-listing port)
2287 (define text-col 24)
2288 (define pos-width 6)
2289 (define byte-width 2)
2291 (define (output text)
2292 (cond ((null? text))
2293 ((pair? text)
2294 (output (car text))
2295 (output (cdr text)))
2296 (else
2297 (display text port))))
2299 (define (print-hex n)
2300 (display (string-ref "0123456789ABCDEF" n) port))
2302 (define (print-byte n)
2303 (print-hex (quotient n 16))
2304 (print-hex (modulo n 16)))
2306 (define (print-pos n)
2307 (if (< n 0)
2308 (display " " port)
2309 (begin
2310 (print-byte (quotient n #x10000))
2311 (print-byte (modulo (quotient n #x100) #x100))
2312 (print-byte (modulo n #x100)))))
2314 (let loop1 ((lst (cdr asm-code-stream)) (pos asm-start-pos) (col 0))
2315 (if (null? lst)
2316 (if (> col 0)
2317 (newline port))
2318 (let ((x (car lst)))
2319 (if (vector? x)
2320 (let ((kind (vector-ref x 0)))
2321 (cond ((eq? kind 'LISTING)
2322 (let loop2 ((col col))
2323 (if (< col text-col)
2324 (begin
2325 (display (integer->char 9) port)
2326 (loop2 (* 8 (+ (quotient col 8) 1))))))
2327 (output (vector-ref x 1))
2328 (newline port)
2329 (loop1 (cdr lst) pos 0))
2330 (else
2331 (compiler-internal-error
2332 "asm-display-listing, code stream not assembled"))))
2333 (if (or (= col 0) (>= col (- text-col byte-width)))
2334 (begin
2335 (if (not (= col 0)) (newline port))
2336 (print-pos pos)
2337 (display " " port)
2338 (print-byte x)
2339 (loop1 (cdr lst) (+ pos 1) (+ (+ pos-width 1) byte-width)))
2340 (begin
2341 (print-byte x)
2342 (loop1 (cdr lst) (+ pos 1) (+ col byte-width)))))))))
2344 ;; (asm-write-code filename) outputs the code stream (i.e. the sequence
2345 ;; of bytes produced) on the named file.
2347 (define (asm-write-code filename)
2348 (with-output-to-file filename
2349 (lambda ()
2350 (let loop ((lst (cdr asm-code-stream)))
2351 (if (not (null? lst))
2352 (let ((x (car lst)))
2353 (if (vector? x)
2354 (let ((kind (vector-ref x 0)))
2355 (if (not (eq? kind 'LISTING))
2356 (compiler-internal-error
2357 "asm-write-code, code stream not assembled"))
2358 (loop (cdr lst)))
2359 (begin
2360 (write-char (integer->char x))
2361 (loop (cdr lst))))))))))
2363 (define (asm-write-hex-file filename)
2364 (with-output-to-file filename
2365 (lambda ()
2367 (define (print-hex n)
2368 (display (string-ref "0123456789ABCDEF" n)))
2370 (define (print-byte n)
2371 (print-hex (quotient n 16))
2372 (print-hex (modulo n 16)))
2374 (define (print-line type addr bytes)
2375 (let ((n (length bytes))
2376 (addr-hi (quotient addr 256))
2377 (addr-lo (modulo addr 256)))
2378 (display ":")
2379 (print-byte n)
2380 (print-byte addr-hi)
2381 (print-byte addr-lo)
2382 (print-byte type)
2383 (for-each print-byte bytes)
2384 (let ((sum
2385 (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
2386 (print-byte sum)
2387 (newline))))
2389 (let loop ((lst (cdr asm-code-stream))
2390 (pos asm-start-pos)
2391 (rev-bytes '()))
2392 (if (not (null? lst))
2393 (let ((x (car lst)))
2394 (if (vector? x)
2395 (let ((kind (vector-ref x 0)))
2396 (if (not (eq? kind 'LISTING))
2397 (compiler-internal-error
2398 "asm-write-hex-file, code stream not assembled"))
2399 (loop (cdr lst)
2400 pos
2401 rev-bytes))
2402 (let ((new-pos
2403 (+ pos 1))
2404 (new-rev-bytes
2405 (cons x
2406 (if (= (modulo pos 16) 0)
2407 (begin
2408 (print-line 0
2409 (- pos (length rev-bytes))
2410 (reverse rev-bytes))
2411 '())
2412 rev-bytes))))
2413 (loop (cdr lst)
2414 new-pos
2415 new-rev-bytes))))
2416 (begin
2417 (if (not (null? rev-bytes))
2418 (print-line 0
2419 (- pos (length rev-bytes))
2420 (reverse rev-bytes)))
2421 (print-line 1 0 '())
2422 (if #t
2423 (begin
2424 (display (- pos asm-start-pos) ##stderr-port)
2425 (display " bytes\n" ##stderr-port)))))))))
2427 ;; Utilities.
2429 (define asm-start-pos #f) ; start position of the code stream
2430 (define asm-big-endian? #f) ; endianness to use
2431 (define asm-code-stream #f) ; current code stream
2433 (define (asm-make-stream) ; create an empty stream
2434 (let ((x (cons '() '())))
2435 (set-car! x x)
2436 x))
2438 (define (asm-code-extend item) ; add an item at the end of current code stream
2439 (let* ((stream asm-code-stream)
2440 (tail (car stream))
2441 (cell (cons item '())))
2442 (set-cdr! tail cell)
2443 (set-car! stream cell)))
2445 (define (asm-pass1) ; construct fixup list and make first label assignment
2446 (let loop ((curr (cdr asm-code-stream))
2447 (fixup-lst '())
2448 (span 0)
2449 (pos asm-start-pos))
2450 (if (null? curr)
2451 (reverse fixup-lst)
2452 (let ((x (car curr)))
2453 (if (vector? x)
2454 (let ((kind (vector-ref x 0)))
2455 (cond ((eq? kind 'LABEL)
2456 (vector-set! x 1 pos) ; first approximation of position
2457 (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
2458 ((eq? kind 'DEFERRED)
2459 (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
2460 (else
2461 (loop (cdr curr) fixup-lst span pos))))
2462 (loop (cdr curr) fixup-lst (+ span 1) (+ pos 1)))))))
2464 ;(##declare (generic))
2466 (define (asm-bits-0-to-7 n) ; return bits 0 to 7 of a signed integer
2467 (modulo n #x100))
2469 (define (asm-bits-8-and-up n) ; return bits 8 and up of a signed integer
2470 (if (>= n 0)
2471 (quotient n #x100)
2472 (- (quotient (+ n 1) #x100) 1)))
2474 (define (asm-bits-16-and-up n) ; return bits 16 and up of a signed integer
2475 (if (>= n 0)
2476 (quotient n #x10000)
2477 (- (quotient (+ n 1) #x10000) 1)))
2479 (define (asm-bits-32-and-up n) ; return bits 32 and up of a signed integer
2480 (if (>= n 0)
2481 (quotient n #x100000000)
2482 (- (quotient (+ n 1) #x100000000) 1)))
2484 ; The following procedures convert floating point numbers into their
2485 ; machine representation. They perform bignum and flonum arithmetic.
2487 (define (asm-float->inexact-exponential-format x)
2489 (define (exp-form-pos x y i)
2490 (let ((i*2 (+ i i)))
2491 (let ((z (if (and (not (< asm-ieee-e-bias i*2))
2492 (not (< x y)))
2493 (exp-form-pos x (* y y) i*2)
2494 (cons x 0))))
2495 (let ((a (car z)) (b (cdr z)))
2496 (let ((i+b (+ i b)))
2497 (if (and (not (< asm-ieee-e-bias i+b))
2498 (not (< a y)))
2499 (begin
2500 (set-car! z (/ a y))
2501 (set-cdr! z i+b)))
2502 z)))))
2504 (define (exp-form-neg x y i)
2505 (let ((i*2 (+ i i)))
2506 (let ((z (if (and (< i*2 asm-ieee-e-bias-minus-1)
2507 (< x y))
2508 (exp-form-neg 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 (< i+b asm-ieee-e-bias-minus-1)
2513 (< a y))
2514 (begin
2515 (set-car! z (/ a y))
2516 (set-cdr! z i+b)))
2517 z)))))
2519 (define (exp-form x)
2520 (if (< x asm-inexact-+1)
2521 (let ((z (exp-form-neg x asm-inexact-+1/2 1)))
2522 (set-car! z (* asm-inexact-+2 (car z)))
2523 (set-cdr! z (- -1 (cdr z)))
2524 z)
2525 (exp-form-pos x asm-inexact-+2 1)))
2527 (if (negative? x)
2528 (let ((z (exp-form (- asm-inexact-0 x))))
2529 (set-car! z (- asm-inexact-0 (car z)))
2530 z)
2531 (exp-form x)))
2533 (define (asm-float->exact-exponential-format x)
2534 (let ((z (asm-float->inexact-exponential-format x)))
2535 (let ((y (car z)))
2536 (cond ((not (< y asm-inexact-+2))
2537 (set-car! z asm-ieee-+m-min)
2538 (set-cdr! z asm-ieee-e-bias-plus-1))
2539 ((not (< asm-inexact--2 y))
2540 (set-car! z asm-ieee--m-min)
2541 (set-cdr! z asm-ieee-e-bias-plus-1))
2542 (else
2543 (set-car! z
2544 (truncate (inexact->exact (* (car z) asm-inexact-m-min))))))
2545 (set-cdr! z (- (cdr z) asm-ieee-m-bits))
2546 z)))
2548 (define (asm-float->bits x) ; returns the 64 bit integer encoding the float "x"
2550 (define (bits a b)
2551 (if (< a asm-ieee-+m-min)
2552 a
2553 (+ (- a asm-ieee-+m-min)
2554 (* (+ (+ b asm-ieee-m-bits) asm-ieee-e-bias)
2555 asm-ieee-+m-min))))
2557 (let ((z (asm-float->exact-exponential-format x)))
2558 (let ((a (car z)) (b (cdr z)))
2559 (if (negative? a)
2560 (+ asm-ieee-sign-bit (bits (- 0 a) b))
2561 (bits a b)))))
2563 ; Parameters for ANSI-IEEE Std 754-1985 representation of
2564 ; doubles (i.e. 64 bit floating point numbers):
2566 (define asm-ieee-m-bits 52)
2567 (define asm-ieee-e-bits 11)
2568 (define asm-ieee-+m-min 4503599627370496) ; (expt 2 asm-ieee-m-bits)
2569 (define asm-ieee--m-min -4503599627370496) ; (- asm-ieee-+m-min)
2570 (define asm-ieee-sign-bit #x8000000000000000); (expt 2 (+ asm-ieee-e-bits asm-ieee-m-bits))
2572 (define asm-ieee-e-bias 1023) ; (- (expt 2 (- asm-ieee-e-bits 1)) 1)
2573 (define asm-ieee-e-bias-plus-1 1024) ; (+ asm-ieee-e-bias 1)
2574 (define asm-ieee-e-bias-minus-1 1022) ; (- asm-ieee-e-bias 1)
2576 (define asm-inexact-m-min (exact->inexact asm-ieee-+m-min))
2577 (define asm-inexact-+2 (exact->inexact 2))
2578 (define asm-inexact--2 (exact->inexact -2))
2579 (define asm-inexact-+1 (exact->inexact 1))
2580 (define asm-inexact-+1/2 (exact->inexact (/ 1 2)))
2581 (define asm-inexact-0 (exact->inexact 0))
2583 ;------------------------------------------------------------------------------
2585 (define min-fixnum-encoding 3)
2586 (define min-fixnum 0)
2587 (define max-fixnum 255)
2588 (define min-rom-encoding (+ min-fixnum-encoding (- max-fixnum min-fixnum) 1))
2589 (define min-ram-encoding 512)
2590 (define max-ram-encoding 4095)
2591 (define min-vec-encoding 4096)
2592 (define max-vec-encoding 8191)
2594 (define code-start #x5000)
2596 (define (predef-constants) (list))
2598 (define (predef-globals) (list))
2600 (define (encode-direct obj)
2601 (cond ((eq? obj #f)
2602 0)
2603 ((eq? obj #t)
2604 1)
2605 ((eq? obj '())
2606 2)
2607 ((and (integer? obj)
2608 (exact? obj)
2609 (>= obj min-fixnum)
2610 (<= obj max-fixnum))
2611 (+ obj (- min-fixnum-encoding min-fixnum)))
2612 (else
2613 #f)))
2615 (define (translate-constant obj)
2616 (if (char? obj)
2617 (char->integer obj)
2618 obj))
2620 (define (encode-constant obj constants)
2621 (let ((o (translate-constant obj)))
2622 (let ((e (encode-direct o)))
2623 (if e
2624 e
2625 (let ((x (assoc o constants))) ;; TODO was assq
2626 (if x
2627 (vector-ref (cdr x) 0)
2628 (compiler-error "unknown object" obj)))))))
2630 (define (add-constant obj constants from-code? cont)
2631 (let ((o (translate-constant obj)))
2632 (let ((e (encode-direct o)))
2633 (if e
2634 (cont constants)
2635 (let ((x (assoc o constants))) ;; TODO was assq
2636 (if x
2637 (begin
2638 (if from-code?
2639 (vector-set! (cdr x) 2 (+ (vector-ref (cdr x) 2) 1)))
2640 (cont constants))
2641 (let* ((descr
2642 (vector #f
2643 (asm-make-label 'constant)
2644 (if from-code? 1 0)
2645 #f))
2646 (new-constants
2647 (cons (cons o descr)
2648 constants)))
2649 (cond ((pair? o)
2650 (add-constants (list (car o) (cdr o))
2651 new-constants
2652 cont))
2653 ((symbol? o)
2654 (cont new-constants))
2655 ((string? o)
2656 (let ((chars (map char->integer (string->list o))))
2657 (vector-set! descr 3 chars)
2658 (add-constant chars
2659 new-constants
2660 #f
2661 cont)))
2662 ((vector? o)
2663 (let ((elems (vector->list o)))
2664 (vector-set! descr 3 elems)
2665 (add-constant elems
2666 new-constants
2667 #f
2668 cont)))
2669 ;; literal vectors (in rom) are stored as a dotted list
2670 ;; (the last 2 elements are stored as (x . y) rather
2671 ;; than (x . (y . ()))), saves a pair by vector
2672 ((u8vector? o)
2673 (let ((elems (list->dotted (u8vector->list o))))
2674 (vector-set! descr 3 elems)
2675 (add-constant elems
2676 new-constants
2677 #f
2678 cont)))
2679 (else
2680 (cont new-constants))))))))))
2682 (define (list->dotted l)
2683 (cons (car l) (if (= (length l) 2)
2684 (cadr l)
2685 (list->dotted (cdr l)))))
2687 (define (dotted-length l)
2688 (if (pair? (cdr l))
2689 (+ 1 (dotted-length (cdr l)))
2690 2))
2692 (define (add-constants objs constants cont)
2693 (if (null? objs)
2694 (cont constants)
2695 (add-constant (car objs)
2696 constants
2697 #f
2698 (lambda (new-constants)
2699 (add-constants (cdr objs)
2700 new-constants
2701 cont)))))
2703 (define (add-global var globals cont)
2704 (let ((x (assq var globals)))
2705 (if x
2706 (begin
2707 ;; increment reference counter
2708 (vector-set! (cdr x) 1 (+ (vector-ref (cdr x) 1) 1))
2709 (cont globals))
2710 (let ((new-globals
2711 (cons (cons var (vector (length globals) 1))
2712 globals)))
2713 (cont new-globals)))))
2715 (define (sort-constants constants)
2716 (let ((csts
2717 (sort-list constants
2718 (lambda (x y)
2719 (> (vector-ref (cdr x) 2)
2720 (vector-ref (cdr y) 2))))))
2721 (let loop ((i min-rom-encoding)
2722 (lst csts))
2723 (if (null? lst)
2724 ;; constants can use all the rom addresses up to 256 constants since
2725 ;; their number is encoded in a byte at the beginning of the bytecode
2726 (if (or (> i min-ram-encoding) (> (- i min-rom-encoding) 256))
2727 (compiler-error "too many constants")
2728 csts)
2729 (begin
2730 (vector-set! (cdr (car lst)) 0 i)
2731 (loop (+ i 1)
2732 (cdr lst)))))))
2734 (define (sort-globals globals) ;; TODO a lot in common with sort-constants, ABSTRACT
2735 (let ((glbs
2736 (sort-list globals
2737 (lambda (x y)
2738 (> (vector-ref (cdr x) 1)
2739 (vector-ref (cdr y) 1))))))
2740 (let loop ((i 0)
2741 (lst glbs))
2742 (if (null? lst)
2743 (if (> i 256) ;; the number of globals is encoded on a byte
2744 (compiler-error "too many global variables")
2745 glbs)
2746 (begin
2747 (vector-set! (cdr (car lst)) 0 i)
2748 (loop (+ i 1)
2749 (cdr lst)))))))
2751 (define assemble
2752 (lambda (code hex-filename)
2753 (let loop1 ((lst code)
2754 (constants (predef-constants))
2755 (globals (predef-globals))
2756 (labels (list)))
2757 (if (pair? lst)
2759 (let ((instr (car lst)))
2760 (cond ((number? instr)
2761 (loop1 (cdr lst)
2762 constants
2763 globals
2764 (cons (cons instr (asm-make-label 'label))
2765 labels)))
2766 ((eq? (car instr) 'push-constant)
2767 (add-constant (cadr instr)
2768 constants
2769 #t
2770 (lambda (new-constants)
2771 (loop1 (cdr lst)
2772 new-constants
2773 globals
2774 labels))))
2775 ((memq (car instr) '(push-global set-global))
2776 (add-global (cadr instr)
2777 globals
2778 (lambda (new-globals)
2779 (loop1 (cdr lst)
2780 constants
2781 new-globals
2782 labels))))
2783 (else
2784 (loop1 (cdr lst)
2785 constants
2786 globals
2787 labels))))
2789 (let ((constants (sort-constants constants))
2790 (globals (sort-globals globals)))
2792 (define (label-instr label opcode)
2793 (asm-at-assembly
2794 ;; if the distance from pc to the label fits in a single byte,
2795 ;; a short instruction is used, containing a relative address
2796 ;; if not, the full 16-bit label is used
2797 ;;; (lambda (self)
2798 ;;; (let ((dist (- (asm-label-pos label) self)))
2799 ;;; (and (< dist 256) ;; TODO have this between -128 and 127 ? would be more flexible, I guess
2800 ;;; (> dist 0)
2801 ;;; 2)))
2802 ;;; (lambda (self)
2803 ;;; (asm-8 (+ opcode 5))
2804 ;;; (asm-8 (- (asm-label-pos label) self)))
2805 ;; TODO doesn't work at the moment
2807 (lambda (self)
2808 3)
2809 (lambda (self)
2810 (let ((pos (- (asm-label-pos label) code-start)))
2811 (asm-8 opcode)
2812 (asm-8 (quotient pos 256))
2813 (asm-8 (modulo pos 256))))))
2815 (define (push-constant n)
2816 (if (<= n 31)
2817 (asm-8 (+ #x00 n))
2818 (begin
2819 (asm-8 (+ #x90 (quotient n 256)))
2820 (asm-8 (modulo n 256)))))
2822 (define (push-stack n)
2823 (if (> n 31)
2824 (compiler-error "stack is too deep")
2825 (asm-8 (+ #x20 n))))
2827 (define (push-global n)
2828 (if (<= n 15)
2829 (asm-8 (+ #x40 n))
2830 (begin (asm-8 #x8e)
2831 (asm-8 n))))
2833 (define (set-global n)
2834 (if (<= n 15)
2835 (asm-8 (+ #x50 n))
2836 (begin (asm-8 #x8f)
2837 (asm-8 n))))
2839 (define (call n)
2840 (if (> n 15)
2841 (compiler-error "call has too many arguments")
2842 (asm-8 (+ #x60 n))))
2844 (define (jump n)
2845 (if (> n 15)
2846 (compiler-error "call has too many arguments")
2847 (asm-8 (+ #x70 n))))
2849 (define (call-toplevel label)
2850 (label-instr label #x80))
2852 (define (jump-toplevel label)
2853 (label-instr label #x81))
2855 (define (goto label)
2856 (label-instr label #x82))
2858 (define (goto-if-false label)
2859 (label-instr label #x83))
2861 (define (closure label)
2862 (label-instr label #x84))
2864 (define (prim n)
2865 (asm-8 (+ #xc0 n)))
2867 (define (prim.number?) (prim 0))
2868 (define (prim.+) (prim 1))
2869 (define (prim.-) (prim 2))
2870 (define (prim.*) (prim 3))
2871 (define (prim.quotient) (prim 4))
2872 (define (prim.remainder) (prim 5))
2873 (define (prim.neg) (prim 6))
2874 (define (prim.=) (prim 7))
2875 (define (prim.<) (prim 8))
2876 (define (prim.ior) (prim 9))
2877 (define (prim.>) (prim 10))
2878 (define (prim.xor) (prim 11))
2879 (define (prim.pair?) (prim 12))
2880 (define (prim.cons) (prim 13))
2881 (define (prim.car) (prim 14))
2882 (define (prim.cdr) (prim 15))
2883 (define (prim.set-car!) (prim 16))
2884 (define (prim.set-cdr!) (prim 17))
2885 (define (prim.null?) (prim 18))
2886 (define (prim.eq?) (prim 19))
2887 (define (prim.not) (prim 20))
2888 (define (prim.get-cont) (prim 21))
2889 (define (prim.graft-to-cont) (prim 22))
2890 (define (prim.return-to-cont) (prim 23))
2891 (define (prim.halt) (prim 24))
2892 (define (prim.symbol?) (prim 25))
2893 (define (prim.string?) (prim 26))
2894 (define (prim.string->list) (prim 27))
2895 (define (prim.list->string) (prim 28))
2896 (define (prim.make-u8vector) (prim 29))
2897 (define (prim.u8vector-ref) (prim 30))
2898 (define (prim.u8vector-set!) (prim 31))
2899 (define (prim.print) (prim 32))
2900 (define (prim.clock) (prim 33))
2901 (define (prim.motor) (prim 34))
2902 (define (prim.led) (prim 35))
2903 (define (prim.led2-color) (prim 36))
2904 (define (prim.getchar-wait) (prim 37))
2905 (define (prim.putchar) (prim 38))
2906 (define (prim.beep) (prim 39))
2907 (define (prim.adc) (prim 40))
2908 (define (prim.u8vector?) (prim 41)) ;; TODO was dac
2909 (define (prim.sernum) (prim 42)) ;; TODO necessary ?
2910 (define (prim.u8vector-length) (prim 43))
2911 (define (prim.u8vector-copy!) (prim 44))
2912 (define (prim.shift) (prim 45))
2913 (define (prim.pop) (prim 46))
2914 (define (prim.return) (prim 47))
2916 (define big-endian? #f)
2918 (asm-begin! code-start #f)
2920 (asm-8 #xfb)
2921 (asm-8 #xd7)
2922 (asm-8 (length constants))
2923 (asm-8 (length globals)) ;; TODO was 0
2925 (pp (list constants: constants globals: globals)) ;; TODO debug
2927 (for-each
2928 (lambda (x)
2929 (let* ((descr (cdr x))
2930 (label (vector-ref descr 1))
2931 (obj (car x)))
2932 (asm-label label)
2933 ;; see the vm source for a description of encodings
2934 (cond ((and (integer? obj) (exact? obj))
2935 (asm-8 0)
2936 (asm-8 (bitwise-and (arithmetic-shift obj -16) 255))
2937 (asm-8 (bitwise-and (arithmetic-shift obj -8) 255))
2938 (asm-8 (bitwise-and obj 255)))
2939 ((pair? obj)
2940 (let ((obj-car (encode-constant (car obj) constants))
2941 (obj-cdr (encode-constant (cdr obj) constants)))
2942 (asm-8 (+ #x80 (arithmetic-shift obj-car -8)))
2943 (asm-8 (bitwise-and obj-car #xff))
2944 (asm-8 (+ 0 (arithmetic-shift obj-cdr -8)))
2945 (asm-8 (bitwise-and obj-cdr #xff))))
2946 ((symbol? obj)
2947 (asm-8 #x80)
2948 (asm-8 0)
2949 (asm-8 #x20)
2950 (asm-8 0))
2951 ((string? obj)
2952 (let ((obj-enc (encode-constant (vector-ref descr 3)
2953 constants)))
2954 (asm-8 (+ #x80 (arithmetic-shift obj-enc -8)))
2955 (asm-8 (bitwise-and obj-enc #xff))
2956 (asm-8 #x40)
2957 (asm-8 0)))
2958 ((vector? obj) ;; BREGG change this, we have no ordinary vectors
2959 ;; TODO this is the OLD representation, NOT GOOD (but not used) BREGG
2960 (let ((obj-enc (encode-constant (vector-ref descr 3)
2961 constants)))
2962 (asm-8 (+ #x80 (arithmetic-shift obj-enc -8)))
2963 (asm-8 (bitwise-and obj-enc #xff))
2964 (asm-8 #x60)
2965 (asm-8 0)))
2966 ((u8vector? obj) ;; NEW, lists for now (internal representation same as ordinary vectors, who don't actually exist)
2967 (let ((obj-enc (encode-constant (vector-ref descr 3)
2968 constants))
2969 (l (dotted-length (vector-ref descr 3))))
2970 ;; length is stored raw, not encoded as an object
2971 (asm-8 (+ #x80 (arithmetic-shift l -8)))
2972 (asm-8 (bitwise-and l #xff))
2973 (asm-8 (+ #x60 (arithmetic-shift obj-enc -8)))
2974 (asm-8 (bitwise-and obj-enc #xff))))
2975 (else
2976 (compiler-error "unknown object type" obj)))))
2977 constants)
2979 (let loop2 ((lst code))
2980 (if (pair? lst)
2981 (let ((instr (car lst)))
2983 (cond ((number? instr)
2984 (let ((label (cdr (assq instr labels))))
2985 (asm-label label)))
2987 ((eq? (car instr) 'entry)
2988 (let ((np (cadr instr))
2989 (rest? (caddr instr)))
2990 (asm-8 (if rest? (- np) np))))
2992 ((eq? (car instr) 'push-constant)
2993 (let ((n (encode-constant (cadr instr) constants)))
2994 (push-constant n)))
2996 ((eq? (car instr) 'push-stack)
2997 (push-stack (cadr instr)))
2999 ((eq? (car instr) 'push-global)
3000 (push-global (vector-ref
3001 (cdr (assq (cadr instr) globals))
3002 0)))
3004 ((eq? (car instr) 'set-global)
3005 (set-global (vector-ref
3006 (cdr (assq (cadr instr) globals))
3007 0)))
3009 ((eq? (car instr) 'call)
3010 (call (cadr instr)))
3012 ((eq? (car instr) 'jump)
3013 (jump (cadr instr)))
3015 ((eq? (car instr) 'call-toplevel)
3016 (let ((label (cdr (assq (cadr instr) labels))))
3017 (call-toplevel label)))
3019 ((eq? (car instr) 'jump-toplevel)
3020 (let ((label (cdr (assq (cadr instr) labels))))
3021 (jump-toplevel label)))
3023 ((eq? (car instr) 'goto)
3024 (let ((label (cdr (assq (cadr instr) labels))))
3025 (goto label)))
3027 ((eq? (car instr) 'goto-if-false)
3028 (let ((label (cdr (assq (cadr instr) labels))))
3029 (goto-if-false label)))
3031 ((eq? (car instr) 'closure)
3032 (let ((label (cdr (assq (cadr instr) labels))))
3033 (closure label)))
3035 ((eq? (car instr) 'prim)
3036 (case (cadr instr)
3037 ((#%number?) (prim.number?))
3038 ((#%+) (prim.+))
3039 ((#%-) (prim.-))
3040 ((#%*) (prim.*))
3041 ((#%quotient) (prim.quotient))
3042 ((#%remainder) (prim.remainder))
3043 ((#%neg) (prim.neg))
3044 ((#%=) (prim.=))
3045 ((#%<) (prim.<))
3046 ((#%ior) (prim.ior))
3047 ((#%>) (prim.>))
3048 ((#%xor) (prim.xor))
3049 ((#%pair?) (prim.pair?))
3050 ((#%cons) (prim.cons))
3051 ((#%car) (prim.car))
3052 ((#%cdr) (prim.cdr))
3053 ((#%set-car!) (prim.set-car!))
3054 ((#%set-cdr!) (prim.set-cdr!))
3055 ((#%null?) (prim.null?))
3056 ((#%eq?) (prim.eq?))
3057 ((#%not) (prim.not))
3058 ((#%get-cont) (prim.get-cont))
3059 ((#%graft-to-cont) (prim.graft-to-cont))
3060 ((#%return-to-cont) (prim.return-to-cont))
3061 ((#%halt) (prim.halt))
3062 ((#%symbol?) (prim.symbol?))
3063 ((#%string?) (prim.string?))
3064 ((#%string->list) (prim.string->list))
3065 ((#%list->string) (prim.list->string))
3066 ((#%make-u8vector) (prim.make-u8vector))
3067 ((#%u8vector-ref) (prim.u8vector-ref))
3068 ((#%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?)) ;; TODO was dac
3080 ((#%sernum) (prim.sernum))
3081 ((#%u8vector-length) (prim.u8vector-length))
3082 ((#%u8vector-copy!) (prim.u8vector-copy!))
3083 (else
3084 (compiler-error "unknown primitive" (cadr instr)))))
3086 ((eq? (car instr) 'return)
3087 (prim.return))
3089 ((eq? (car instr) 'pop)
3090 (prim.pop))
3092 ((eq? (car instr) 'shift)
3093 (prim.shift))
3095 (else
3096 (compiler-error "unknown instruction" instr)))
3098 (loop2 (cdr lst)))))
3100 (asm-assemble)
3102 (asm-write-hex-file hex-filename)
3104 (asm-end!))))))
3106 (define execute
3107 (lambda (hex-filename)
3108 '
3109 (if #f
3110 (begin
3111 (shell-command "gcc -o picobit-vm picobit-vm.c")
3112 (shell-command (string-append "./picobit-vm " hex-filename)))
3113 (shell-command (string-append "./robot . 1 " hex-filename)))))
3115 (define (sort-list l <?)
3117 (define (mergesort l)
3119 (define (merge l1 l2)
3120 (cond ((null? l1) l2)
3121 ((null? l2) l1)
3122 (else
3123 (let ((e1 (car l1)) (e2 (car l2)))
3124 (if (<? e1 e2)
3125 (cons e1 (merge (cdr l1) l2))
3126 (cons e2 (merge l1 (cdr l2))))))))
3128 (define (split l)
3129 (if (or (null? l) (null? (cdr l)))
3130 l
3131 (cons (car l) (split (cddr l)))))
3133 (if (or (null? l) (null? (cdr l)))
3134 l
3135 (let* ((l1 (mergesort (split l)))
3136 (l2 (mergesort (split (cdr l)))))
3137 (merge l1 l2))))
3139 (mergesort l))
3141 ;------------------------------------------------------------------------------
3143 (define compile
3144 (lambda (filename)
3145 (let* ((node (parse-file filename))
3146 (hex-filename
3147 (string-append
3148 (path-strip-extension filename)
3149 ".hex")))
3151 (adjust-unmutable-references! node)
3153 ; (pp (node->expr node))
3155 (let ((ctx (comp-none node (make-init-context))))
3156 (let ((prog (linearize (optimize-code (context-code ctx)))))
3157 ; (pp (list code: prog env: (context-env ctx)))
3158 (assemble prog hex-filename)
3159 (execute hex-filename))))))
3162 (define main
3163 (lambda (filename)
3164 ;;; (current-exception-handler (lambda (e) (pp e) (##repl))) ;; TODO wow, that's useful, ok, maybe not so much, since we lose the error message
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 '())))))))