| blob | bccefe96926d9b81b12a2547c151c94001a1b20e |
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
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
187 sets
188 defs
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 1 #f #f)) ;; ADDED
236 (make-var '#%u8vector-ref #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED
237 (make-var '#%u8vector-set! #t '() '() '() #f (make-primitive 3 #f #t)) ;; ADDED
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)) ;; ADDED
252 (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 ;; TODO have the arg length ?
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 (string->list . #%string->list)
280 (list->string . #%list->string)
281 (clock . #%clock)
282 (beep . #%beep)
283 (light . #%adc)
284 (adc . #%adc)
285 (sernum . #%sernum)
286 (motor . #%motor)
287 (led . #%led)
288 (bitwise-ior . #%ior)
289 (bitwise-xor . #%xor)
290 (current-time . #%clock)
291 (u8vector-length . #%u8vector-length)
292 (u8vector-ref . #%u8vector-ref)
293 (u8vector-set! . #%u8vector-set!)
294 ))
296 (define env-lookup
297 (lambda (env id)
298 (let loop ((lst env) (id id))
299 (let ((b (car lst)))
300 (cond ((and (renaming? b)
301 (assq id (renaming-renamings b)))
302 =>
303 (lambda (x)
304 (loop (cdr lst) (cadr x))))
305 ((and (var? b)
306 (eq? (var-id b) id))
307 b)
308 ((null? (cdr lst))
309 (let ((x (make-var id #t '() '() '() #f #f)))
310 (set-cdr! lst (cons x '()))
311 x))
312 (else
313 (loop (cdr lst) id)))))))
315 (define env-extend
316 (lambda (env ids def)
317 (append (map (lambda (id)
318 (make-var id #f '() '() (list def) #f #f))
319 ids)
320 env)))
322 (define env-extend-renamings
323 (lambda (env renamings)
324 (cons (make-renaming renamings) env)))
326 ;-----------------------------------------------------------------------------
328 ;; Parsing.
330 (define parse-program
331 (lambda (expr env)
332 (let ((x (parse-top expr env)))
333 (cond ((null? x)
334 (parse 'value #f env))
335 ((null? (cdr x))
336 (car x))
337 (else
338 (let ((r (make-seq #f x)))
339 (for-each (lambda (y) (node-parent-set! y r)) x)
340 r))))))
342 (define parse-top
343 (lambda (expr env)
344 (cond ((and (pair? expr)
345 (eq? (car expr) 'begin))
346 (parse-top-list (cdr expr) env))
347 ((and (pair? expr)
348 (eq? (car expr) 'hide))
349 (parse-top-hide (cadr expr) (cddr expr) env))
350 ((and (pair? expr)
351 (eq? (car expr) 'rename))
352 (parse-top-rename (cadr expr) (cddr expr) env))
353 ((and (pair? expr)
354 (eq? (car expr) 'define))
355 (let ((var
356 (if (pair? (cadr expr))
357 (car (cadr expr))
358 (cadr expr)))
359 (val
360 (if (pair? (cadr expr))
361 (cons 'lambda (cons (cdr (cadr expr)) (cddr expr)))
362 (caddr expr))))
363 (let* ((var2 (env-lookup env var))
364 (val2 (parse 'value val env))
365 (r (make-def #f (list val2) var2)))
366 (node-parent-set! val2 r)
367 (var-defs-set! var2 (cons r (var-defs var2)))
368 (list r))))
369 (else
370 (list (parse 'value expr env))))))
372 (define parse-top-list
373 (lambda (lst env)
374 (if (pair? lst)
375 (append (parse-top (car lst) env)
376 (parse-top-list (cdr lst) env))
377 '())))
379 (define parse-top-hide
380 (lambda (renamings body env)
381 (append
382 (parse-top-list body
383 (env-extend-renamings env renamings))
384 #|
385 (parse-top-list
386 (map (lambda (x) (list 'define (car x) (cadr x))) renamings)
387 env)
388 |#
389 )))
391 (define parse-top-rename
392 (lambda (renamings body env)
393 (parse-top-list body
394 (env-extend-renamings env renamings))))
396 (define parse
397 (lambda (use expr env)
398 (cond ((self-eval? expr)
399 (make-cst #f '() expr))
400 ((symbol? expr)
401 (let* ((var (env-lookup env expr))
402 (r (make-ref #f '() var)))
403 (var-refs-set! var (cons r (var-refs var)))
404 r))
405 ((and (pair? expr) ;; ADDED, when we have a true macroexpander, get rid
406 (eq? (car expr) 'cond))
407 (parse use
408 `(if ,(caadr expr)
409 (begin ,@(cdadr expr))
410 ,(if (null? (cddr expr))
411 #f
412 `(cond ,@(cddr expr))))
413 env))
414 ((and (pair? expr)
415 (eq? (car expr) 'set!))
416 (let ((var (env-lookup env (cadr expr))))
417 (if (var-global? var)
418 (let* ((val (parse 'value (caddr expr) env))
419 (r (make-set #f (list val) var)))
420 (node-parent-set! val r)
421 (var-sets-set! var (cons r (var-sets var)))
422 r)
423 (compiler-error "set! is only permitted on global variables"))))
424 ((and (pair? expr) ;; TODO since literal vectors are quoted, this does the job
425 (eq? (car expr) 'quote))
426 (make-cst #f '() (cadr expr)))
427 ((and (pair? expr)
428 (eq? (car expr) 'if))
429 (let* ((a (parse 'test (cadr expr) env))
430 (b (parse use (caddr expr) env))
431 (c (if (null? (cdddr expr))
432 (make-cst #f '() #f)
433 (parse use (cadddr expr) env)))
434 (r (make-if #f (list a b c))))
435 (node-parent-set! a r)
436 (node-parent-set! b r)
437 (node-parent-set! c r)
438 r))
439 ((and (pair? expr)
440 (eq? (car expr) 'lambda))
441 (let* ((pattern (cadr expr))
442 (ids (extract-ids pattern))
443 (r (make-prc #f '() #f (has-rest-param? pattern) #f))
444 (new-env (env-extend env ids r))
445 (body (parse-body (cddr expr) new-env)))
446 (prc-params-set! r (map (lambda (id) (env-lookup new-env id)) ids))
447 (node-children-set! r (list body))
448 (node-parent-set! body r)
449 r))
450 ((and (pair? expr)
451 (eq? (car expr) 'begin))
452 (let* ((exprs (map (lambda (x) (parse 'value x env)) (cdr expr)))
453 (r (make-seq #f exprs)))
454 (for-each (lambda (x) (node-parent-set! x r)) exprs)
455 r))
456 ((and (pair? expr)
457 (eq? (car expr) 'let))
458 (if (symbol? (cadr expr))
459 (compiler-error "named let is not implemented")
460 (parse use
461 (cons (cons 'lambda
462 (cons (map car (cadr expr))
463 (cddr expr)))
464 (map cadr (cadr expr)))
465 env)))
466 ((and (pair? expr)
467 (eq? (car expr) 'let*))
468 (if (null? (cadr expr))
469 (parse use
470 (cons 'let (cdr expr))
471 env)
472 (parse use
473 (list 'let
474 (list (list (caar (cadr expr))
475 (cadar (cadr expr))))
476 (cons 'let*
477 (cons (cdr (cadr expr))
478 (cddr expr))))
479 env)))
480 ((and (pair? expr)
481 (eq? (car expr) 'and))
482 (cond ((null? (cdr expr))
483 (parse use
484 #t
485 env))
486 ((null? (cddr expr))
487 (parse use
488 (cadr expr)
489 env))
490 (else
491 (parse use
492 (list 'if
493 (cadr expr)
494 (cons 'and (cddr expr))
495 #f)
496 env))))
497 ((and (pair? expr)
498 (eq? (car expr) 'or))
499 (cond ((null? (cdr expr))
500 (parse use
501 #f
502 env))
503 ((null? (cddr expr))
504 (parse use
505 (cadr expr)
506 env))
507 ((eq? use 'test)
508 (parse use
509 (list 'if
510 (cadr expr)
511 #t
512 (cons 'or (cddr expr)))
513 env))
514 (else
515 (parse use
516 (let ((v (gensym)))
517 (list 'let
518 (list (list v (cadr expr)))
519 (list 'if
520 v
521 v
522 (cons 'or (cddr expr)))))
523 env))))
524 ;; primitive substitution here
525 ((and (pair? expr)
526 (assoc (car expr) substitute-primitives))
527 =>
528 (lambda (prim)
529 (parse use
530 (cons (cdr prim) (cdr expr))
531 env)))
532 ;; binary arthimetic operations can use primitives directly
533 ((and (pair? expr)
534 (= (length (cdr expr)) 2)
535 (assoc (car expr) '((+ . #%+) (- . #%-) (* . #%*))))
536 =>
537 (lambda (prim)
538 (parse use
539 (cons (cdr prim) (cdr expr))
540 env)))
541 ((and (pair? expr)
542 (memq (car expr)
543 '(quote quasiquote unquote unquote-splicing lambda if
544 set! cond and or case let let* letrec begin do define
545 delay)))
546 (compiler-error "the compiler does not implement the special form" (car expr)))
547 ((pair? expr)
548 (let* ((exprs (map (lambda (x) (parse 'value x env)) expr))
549 (r (make-call #f exprs)))
550 (for-each (lambda (x) (node-parent-set! x r)) exprs)
551 r))
552 (else
553 (compiler-error "unknown expression" expr)))))
555 (define parse-body
556 (lambda (exprs env)
557 (parse 'value (cons 'begin exprs) env)))
559 (define self-eval?
560 (lambda (expr)
561 (or (number? expr)
562 (char? expr)
563 (boolean? expr)
564 (string? expr))))
566 (define extract-ids
567 (lambda (pattern)
568 (if (pair? pattern)
569 (cons (car pattern) (extract-ids (cdr pattern)))
570 (if (symbol? pattern)
571 (cons pattern '())
572 '()))))
574 (define has-rest-param?
575 (lambda (pattern)
576 (if (pair? pattern)
577 (has-rest-param? (cdr pattern))
578 (symbol? pattern))))
580 ;-----------------------------------------------------------------------------
582 ;; Compilation context representation.
584 (define-type context
585 code
586 env
587 env2
588 )
590 (define context-change-code
591 (lambda (ctx code)
592 (make-context code
593 (context-env ctx)
594 (context-env2 ctx))))
596 (define context-change-env
597 (lambda (ctx env)
598 (make-context (context-code ctx)
599 env
600 (context-env2 ctx))))
602 (define context-change-env2
603 (lambda (ctx env2)
604 (make-context (context-code ctx)
605 (context-env ctx)
606 env2)))
608 (define make-init-context
609 (lambda ()
610 (make-context (make-init-code)
611 (make-init-env)
612 #f)))
614 (define context-make-label
615 (lambda (ctx)
616 (context-change-code ctx (code-make-label (context-code ctx)))))
618 (define context-last-label
619 (lambda (ctx)
620 (code-last-label (context-code ctx))))
622 (define context-add-bb
623 (lambda (ctx label)
624 (context-change-code ctx (code-add-bb (context-code ctx) label))))
626 (define context-add-instr
627 (lambda (ctx instr)
628 (context-change-code ctx (code-add-instr (context-code ctx) instr))))
630 ;; Representation of code.
632 (define-type code
633 last-label
634 rev-bbs
635 )
637 (define-type bb
638 label
639 rev-instrs
640 )
642 (define make-init-code
643 (lambda ()
644 (make-code 0
645 (list (make-bb 0 (list))))))
647 (define code-make-label
648 (lambda (code)
649 (let ((label (+ (code-last-label code) 1)))
650 (make-code label
651 (code-rev-bbs code)))))
653 (define code-add-bb
654 (lambda (code label)
655 (make-code
656 (code-last-label code)
657 (cons (make-bb label '())
658 (code-rev-bbs code)))))
660 (define code-add-instr
661 (lambda (code instr)
662 (let* ((rev-bbs (code-rev-bbs code))
663 (bb (car rev-bbs))
664 (rev-instrs (bb-rev-instrs bb)))
665 (make-code
666 (code-last-label code)
667 (cons (make-bb (bb-label bb)
668 (cons instr rev-instrs))
669 (cdr rev-bbs))))))
671 ;; Representation of compile-time stack.
673 (define-type stack
674 size ; number of slots
675 slots ; for each slot, the variable (or #f) contained in the slot
676 )
678 (define make-init-stack
679 (lambda ()
680 (make-stack 0 '())))
682 (define stack-extend
683 (lambda (x nb-slots stk)
684 (let ((size (stack-size stk)))
685 (make-stack
686 (+ size nb-slots)
687 (append (repeat nb-slots x) (stack-slots stk))))))
689 (define stack-discard
690 (lambda (nb-slots stk)
691 (let ((size (stack-size stk)))
692 (make-stack
693 (- size nb-slots)
694 (list-tail (stack-slots stk) nb-slots)))))
696 ;; Representation of compile-time environment.
698 (define-type env
699 local
700 closed
701 )
703 (define make-init-env
704 (lambda ()
705 (make-env (make-init-stack)
706 '())))
708 (define env-change-local
709 (lambda (env local)
710 (make-env local
711 (env-closed env))))
713 (define env-change-closed
714 (lambda (env closed)
715 (make-env (env-local env)
716 closed)))
718 (define find-local-var
719 (lambda (var env)
720 (let ((i (pos-in-list var (stack-slots (env-local env)))))
721 (or i
722 (- (+ (pos-in-list var (env-closed env)) 1))))))
724 (define prc->env
725 (lambda (prc)
726 (make-env
727 (let ((params (prc-params prc)))
728 (make-stack (length params)
729 (append (map var-id params) '())))
730 (let ((vars (varset->list (non-global-fv prc))))
731 ; (pp (map var-id vars))
732 (map var-id vars)))))
734 ;-----------------------------------------------------------------------------
736 (define gen-instruction
737 (lambda (instr nb-pop nb-push ctx)
738 (let* ((env
739 (context-env ctx))
740 (stk
741 (stack-extend #f
742 nb-push
743 (stack-discard nb-pop
744 (env-local env)))))
745 (context-add-instr (context-change-env ctx (env-change-local env stk))
746 instr))))
748 (define gen-entry
749 (lambda (nparams rest? ctx)
750 (gen-instruction (list 'entry nparams rest?) 0 0 ctx)))
752 (define gen-push-constant
753 (lambda (val ctx)
754 (gen-instruction (list 'push-constant val) 0 1 ctx)))
756 (define gen-push-unspecified
757 (lambda (ctx)
758 (gen-push-constant #f ctx)))
760 (define gen-push-local-var
761 (lambda (var ctx)
762 ; (pp (list var: var local: (stack-slots (env-local (context-env ctx))) (env-closed (context-env ctx))))
763 (let ((i (find-local-var var (context-env ctx))))
764 (if (>= i 0)
765 (gen-push-stack i ctx)
766 (gen-push-stack
767 (+ 1 ;; TODO the +1 was added because closures are not really pairs anymore, they only have a cdr
768 (- -1 i)
769 (length (stack-slots (env-local (context-env ctx))))) ctx)))))
771 (define gen-push-stack
772 (lambda (pos ctx)
773 (gen-instruction (list 'push-stack pos) 0 1 ctx)))
775 (define gen-push-global
776 (lambda (var ctx)
777 (gen-instruction (list 'push-global var) 0 1 ctx)))
779 (define gen-set-global
780 (lambda (var ctx)
781 (gen-instruction (list 'set-global var) 1 0 ctx)))
783 (define gen-call
784 (lambda (nargs ctx)
785 (gen-instruction (list 'call nargs) (+ nargs 1) 1 ctx)))
787 (define gen-jump
788 (lambda (nargs ctx)
789 (gen-instruction (list 'jump nargs) (+ nargs 1) 1 ctx)))
791 (define gen-call-toplevel
792 (lambda (nargs id ctx)
793 (gen-instruction (list 'call-toplevel id) nargs 1 ctx)))
795 (define gen-jump-toplevel
796 (lambda (nargs id ctx)
797 (gen-instruction (list 'jump-toplevel id) nargs 1 ctx)))
799 (define gen-goto
800 (lambda (label ctx)
801 (gen-instruction (list 'goto label) 0 0 ctx)))
803 (define gen-goto-if-false
804 (lambda (label-false label-true ctx)
805 (gen-instruction (list 'goto-if-false label-false label-true) 1 0 ctx)))
807 (define gen-closure
808 (lambda (label-entry ctx)
809 (gen-instruction (list 'closure label-entry) 1 1 ctx)))
811 (define gen-prim
812 (lambda (id nargs unspec-result? ctx)
813 (gen-instruction
814 (list 'prim id)
815 nargs
816 (if unspec-result? 0 1)
817 ctx)))
819 (define gen-shift
820 (lambda (n ctx)
821 (if (> n 0)
822 (gen-instruction (list 'shift) 1 0 (gen-shift (- n 1) ctx))
823 ctx)))
825 (define gen-pop
826 (lambda (ctx)
827 (gen-instruction (list 'pop) 1 0 ctx)))
829 (define gen-return
830 (lambda (ctx)
831 (let ((ss (stack-size (env-local (context-env ctx)))))
832 (gen-instruction (list 'return) ss 0 ctx))))
834 ;-----------------------------------------------------------------------------
836 (define child1
837 (lambda (node)
838 (car (node-children node))))
840 (define child2
841 (lambda (node)
842 (cadr (node-children node))))
844 (define child3
845 (lambda (node)
846 (caddr (node-children node))))
848 (define comp-none
849 (lambda (node ctx)
851 (cond ((or (cst? node)
852 (ref? node)
853 (prc? node))
854 ctx)
856 ((def? node)
857 (let ((var (def-var node)))
858 (if (toplevel-prc-with-non-rest-correct-calls? var)
859 (comp-prc (child1 node) #f ctx)
860 (if (var-needed? var)
861 (let ((ctx2 (comp-push (child1 node) ctx)))
862 (gen-set-global (var-id var) ctx2))
863 (comp-none (child1 node) ctx)))))
865 ((set? node)
866 (let ((var (set-var node)))
867 (if (var-needed? var)
868 (let ((ctx2 (comp-push (child1 node) ctx)))
869 (gen-set-global (var-id var) ctx2))
870 (comp-none (child1 node) ctx))))
872 ((if? node)
873 (let* ((ctx2
874 (context-make-label ctx))
875 (label-then
876 (context-last-label ctx2))
877 (ctx3
878 (context-make-label ctx2))
879 (label-else
880 (context-last-label ctx3))
881 (ctx4
882 (context-make-label ctx3))
883 (label-then-join
884 (context-last-label ctx4))
885 (ctx5
886 (context-make-label ctx4))
887 (label-else-join
888 (context-last-label ctx5))
889 (ctx6
890 (context-make-label ctx5))
891 (label-join
892 (context-last-label ctx6))
893 (ctx7
894 (comp-test (child1 node) label-then label-else ctx6))
895 (ctx8
896 (gen-goto
897 label-else-join
898 (comp-none (child3 node)
899 (context-change-env2
900 (context-add-bb ctx7 label-else)
901 #f))))
902 (ctx9
903 (gen-goto
904 label-then-join
905 (comp-none (child2 node)
906 (context-change-env
907 (context-add-bb ctx8 label-then)
908 (context-env2 ctx7)))))
909 (ctx10
910 (gen-goto
911 label-join
912 (context-add-bb ctx9 label-else-join)))
913 (ctx11
914 (gen-goto
915 label-join
916 (context-add-bb ctx10 label-then-join)))
917 (ctx12
918 (context-add-bb ctx11 label-join)))
919 ctx12))
921 ((call? node)
922 (comp-call node 'none ctx))
924 ((seq? node)
925 (let ((children (node-children node)))
926 (if (null? children)
927 ctx
928 (let loop ((lst children)
929 (ctx ctx))
930 (if (null? (cdr lst))
931 (comp-none (car lst) ctx)
932 (loop (cdr lst)
933 (comp-none (car lst) ctx)))))))
935 (else
936 (compiler-error "unknown expression type" node)))))
938 (define comp-tail
939 (lambda (node ctx)
941 (cond ((or (cst? node)
942 (ref? node)
943 (def? node)
944 (set? node)
945 (prc? node)
946 ; (call? node)
947 )
948 (gen-return (comp-push node ctx)))
950 ((if? node)
951 (let* ((ctx2
952 (context-make-label ctx))
953 (label-then
954 (context-last-label ctx2))
955 (ctx3
956 (context-make-label ctx2))
957 (label-else
958 (context-last-label ctx3))
959 (ctx4
960 (comp-test (child1 node) label-then label-else ctx3))
961 (ctx5
962 (comp-tail (child3 node)
963 (context-change-env2
964 (context-add-bb ctx4 label-else)
965 #f)))
966 (ctx6
967 (comp-tail (child2 node)
968 (context-change-env
969 (context-add-bb ctx5 label-then)
970 (context-env2 ctx4)))))
971 ctx6))
973 ((call? node)
974 (comp-call node 'tail ctx))
976 ((seq? node)
977 (let ((children (node-children node)))
978 (if (null? children)
979 (gen-return (gen-push-unspecified ctx))
980 (let loop ((lst children)
981 (ctx ctx))
982 (if (null? (cdr lst))
983 (comp-tail (car lst) ctx)
984 (loop (cdr lst)
985 (comp-none (car lst) ctx)))))))
987 (else
988 (compiler-error "unknown expression type" node)))))
990 (define comp-push
991 (lambda (node ctx)
993 '(
994 (display "--------------\n")
995 (pp (node->expr node))
996 (pp env)
997 (pp stk)
998 )
1000 (cond ((cst? node)
1001 (let ((val (cst-val node)))
1002 (gen-push-constant val ctx)))
1004 ((ref? node)
1005 (let ((var (ref-var node)))
1006 (if (var-global? var)
1007 (if (null? (var-defs var))
1008 (compiler-error "undefined variable:" (var-id var))
1009 (let ((val (child1 (car (var-defs var)))))
1010 (if (and (not (mutable-var? var))
1011 (cst? val)) ;; immutable global, counted as cst
1012 (gen-push-constant (cst-val val) ctx)
1013 (gen-push-global (var-id var) ctx))))
1014 (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)
1016 ((or (def? node)
1017 (set? node))
1018 (gen-push-unspecified (comp-none node ctx)))
1020 ((if? node)
1021 (let* ((ctx2
1022 (context-make-label ctx))
1023 (label-then
1024 (context-last-label ctx2))
1025 (ctx3
1026 (context-make-label ctx2))
1027 (label-else
1028 (context-last-label ctx3))
1029 (ctx4
1030 (context-make-label ctx3))
1031 (label-then-join
1032 (context-last-label ctx4))
1033 (ctx5
1034 (context-make-label ctx4))
1035 (label-else-join
1036 (context-last-label ctx5))
1037 (ctx6
1038 (context-make-label ctx5))
1039 (label-join
1040 (context-last-label ctx6))
1041 (ctx7
1042 (comp-test (child1 node) label-then label-else ctx6))
1043 (ctx8
1044 (gen-goto
1045 label-else-join
1046 (comp-push (child3 node)
1047 (context-change-env2
1048 (context-add-bb ctx7 label-else)
1049 #f))))
1050 (ctx9
1051 (gen-goto
1052 label-then-join
1053 (comp-push (child2 node)
1054 (context-change-env
1055 (context-add-bb ctx8 label-then)
1056 (context-env2 ctx7)))))
1057 (ctx10
1058 (gen-goto
1059 label-join
1060 (context-add-bb ctx9 label-else-join)))
1061 (ctx11
1062 (gen-goto
1063 label-join
1064 (context-add-bb ctx10 label-then-join)))
1065 (ctx12
1066 (context-add-bb ctx11 label-join)))
1067 ctx12))
1069 ((prc? node)
1070 (comp-prc node #t ctx))
1072 ((call? node)
1073 (comp-call node 'push ctx))
1075 ((seq? node)
1076 (let ((children (node-children node)))
1077 (if (null? children)
1078 (gen-push-unspecified ctx)
1079 (let loop ((lst children)
1080 (ctx ctx))
1081 (if (null? (cdr lst))
1082 (comp-push (car lst) ctx)
1083 (loop (cdr lst)
1084 (comp-none (car lst) ctx)))))))
1086 (else
1087 (compiler-error "unknown expression type" node)))))
1089 (define (build-closure label-entry vars ctx)
1091 (define (build vars ctx)
1092 (if (null? vars)
1093 (gen-push-constant '() ctx)
1094 (gen-prim '#%cons
1095 2
1096 #f
1097 (build (cdr vars)
1098 (gen-push-local-var (car vars) ctx)))))
1100 (if (null? vars)
1101 (gen-closure label-entry
1102 (gen-push-constant '() ctx))
1103 (gen-closure label-entry
1104 (build vars ctx))))
1105 ;; 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
1107 (define comp-prc
1108 (lambda (node closure? ctx)
1109 (let* ((ctx2
1110 (context-make-label ctx))
1111 (label-entry
1112 (context-last-label ctx2))
1113 (ctx3
1114 (context-make-label ctx2))
1115 (label-continue
1116 (context-last-label ctx3))
1117 (body-env
1118 (prc->env node))
1119 (ctx4
1120 (if closure?
1121 (build-closure label-entry (env-closed body-env) ctx3)
1122 ctx3))
1123 (ctx5
1124 (gen-goto label-continue ctx4))
1125 (ctx6
1126 (gen-entry (length (prc-params node))
1127 (prc-rest? node)
1128 (context-add-bb (context-change-env ctx5
1129 body-env)
1130 label-entry)))
1131 (ctx7
1132 (comp-tail (child1 node) ctx6)))
1133 (prc-entry-label-set! node label-entry)
1134 (context-add-bb (context-change-env ctx7 (context-env ctx5))
1135 label-continue))))
1137 (define comp-call
1138 (lambda (node reason ctx)
1139 (let* ((op (child1 node))
1140 (args (cdr (node-children node)))
1141 (nargs (length args)))
1142 (let loop ((lst args)
1143 (ctx ctx))
1144 (if (pair? lst)
1146 (let ((arg (car lst)))
1147 (loop (cdr lst)
1148 (comp-push arg ctx)))
1150 (cond ((and (ref? op)
1151 (var-primitive (ref-var op)))
1152 (let* ((var (ref-var op))
1153 (id (var-id var))
1154 (primitive (var-primitive var))
1155 (prim-nargs (primitive-nargs primitive)))
1157 (define use-result
1158 (lambda (ctx2)
1159 (cond ((eq? reason 'tail)
1160 (gen-return
1161 (if (primitive-unspecified-result? primitive)
1162 (gen-push-unspecified ctx2)
1163 ctx2)))
1164 ((eq? reason 'push)
1165 (if (primitive-unspecified-result? primitive)
1166 (gen-push-unspecified ctx2)
1167 ctx2))
1168 (else
1169 (if (primitive-unspecified-result? primitive)
1170 ctx2
1171 (gen-pop ctx2))))))
1173 (use-result
1174 (if (primitive-inliner primitive)
1175 ((primitive-inliner primitive) ctx)
1176 (if (not (= nargs prim-nargs))
1177 (compiler-error "primitive called with wrong number of arguments" id)
1178 (gen-prim
1179 id
1180 prim-nargs
1181 (primitive-unspecified-result? primitive)
1182 ctx))))))
1185 ((and (ref? op)
1186 (toplevel-prc-with-non-rest-correct-calls? (ref-var op)))
1187 =>
1188 (lambda (prc)
1189 (cond ((eq? reason 'tail)
1190 (gen-jump-toplevel nargs prc ctx))
1191 ((eq? reason 'push)
1192 (gen-call-toplevel nargs prc ctx))
1193 (else
1194 (gen-pop (gen-call-toplevel nargs prc ctx))))))
1196 (else
1197 (let ((ctx2 (comp-push op ctx)))
1198 (cond ((eq? reason 'tail)
1199 (gen-jump nargs ctx2))
1200 ((eq? reason 'push)
1201 (gen-call nargs ctx2))
1202 (else
1203 (gen-pop (gen-call nargs ctx2))))))))))))
1205 (define comp-test
1206 (lambda (node label-true label-false ctx)
1207 (cond ((cst? node)
1208 (let ((ctx2
1209 (gen-goto
1210 (let ((val (cst-val node)))
1211 (if val
1212 label-true
1213 label-false))
1214 ctx)))
1215 (context-change-env2 ctx2 (context-env ctx2))))
1217 ((or (ref? node)
1218 (def? node)
1219 (set? node)
1220 (if? node)
1221 (call? node)
1222 (seq? node))
1223 (let* ((ctx2
1224 (comp-push node ctx))
1225 (ctx3
1226 (gen-goto-if-false label-false label-true ctx2)))
1227 (context-change-env2 ctx3 (context-env ctx3))))
1229 ((prc? node)
1230 (let ((ctx2
1231 (gen-goto label-true ctx)))
1232 (context-change-env2 ctx2 (context-env ctx2))))
1234 (else
1235 (compiler-error "unknown expression type" node)))))
1237 ;-----------------------------------------------------------------------------
1239 (define toplevel-prc?
1240 (lambda (var)
1241 (and (not (mutable-var? var))
1242 (let ((d (var-defs var)))
1243 (and (pair? d)
1244 (null? (cdr d))
1245 (let ((val (child1 (car d))))
1246 (and (prc? val)
1247 val)))))))
1249 (define toplevel-prc-with-non-rest-correct-calls?
1250 (lambda (var)
1251 (let ((prc (toplevel-prc? var)))
1252 (and prc
1253 (not (prc-rest? prc))
1254 (every (lambda (r)
1255 (let ((parent (node-parent r)))
1256 (and (call? parent)
1257 (eq? (child1 parent) r)
1258 (= (length (prc-params prc))
1259 (- (length (node-children parent)) 1)))))
1260 (var-refs var))
1261 prc))))
1263 (define mutable-var?
1264 (lambda (var)
1265 (not (null? (var-sets var)))))
1267 (define global-fv
1268 (lambda (node)
1269 (list->varset
1270 (keep var-global?
1271 (varset->list (fv node))))))
1273 (define non-global-fv
1274 (lambda (node)
1275 (list->varset
1276 (keep (lambda (x) (not (var-global? x)))
1277 (varset->list (fv node))))))
1279 (define fv
1280 (lambda (node)
1281 (cond ((cst? node)
1282 (varset-empty))
1283 ((ref? node)
1284 (let ((var (ref-var node)))
1285 (varset-singleton var)))
1286 ((def? node)
1287 (let ((var (def-var node))
1288 (val (child1 node)))
1289 (varset-union
1290 (varset-singleton var)
1291 (fv val))))
1292 ((set? node)
1293 (let ((var (set-var node))
1294 (val (child1 node)))
1295 (varset-union
1296 (varset-singleton var)
1297 (fv val))))
1298 ((if? node)
1299 (let ((a (list-ref (node-children node) 0))
1300 (b (list-ref (node-children node) 1))
1301 (c (list-ref (node-children node) 2)))
1302 (varset-union-multi (list (fv a) (fv b) (fv c)))))
1303 ((prc? node)
1304 (let ((body (list-ref (node-children node) 0)))
1305 (varset-difference
1306 (fv body)
1307 (build-params-varset (prc-params node)))))
1308 ((call? node)
1309 (varset-union-multi (map fv (node-children node))))
1310 ((seq? node)
1311 (varset-union-multi (map fv (node-children node))))
1312 (else
1313 (compiler-error "unknown expression type" node)))))
1315 (define build-params-varset
1316 (lambda (params)
1317 (list->varset params)))
1319 (define mark-needed-global-vars!
1320 (lambda (global-env node)
1322 (define readyq
1323 (env-lookup global-env '#%readyq))
1325 (define mark-var!
1326 (lambda (var)
1327 (if (and (var-global? var)
1328 (not (var-needed? var))
1329 ;; globals that obey the following conditions are considered
1330 ;; to be constants
1331 (not (and (not (mutable-var? var))
1332 (> (length (var-defs var)) 0) ;; TODO to catch errors for primitives
1333 (cst? (child1 (car (var-defs var)))))))
1334 (begin
1335 (var-needed?-set! var #t)
1336 (for-each
1337 (lambda (def)
1338 (let ((val (child1 def)))
1339 (if (side-effect-less? val)
1340 (mark! val))))
1341 (var-defs var))
1342 (if (eq? var readyq)
1343 (begin
1344 (mark-var!
1345 (env-lookup global-env '#%start-first-process))
1346 (mark-var!
1347 (env-lookup global-env '#%exit))))))))
1349 (define side-effect-less?
1350 (lambda (node)
1351 (or (cst? node)
1352 (ref? node)
1353 (prc? node))))
1355 (define mark!
1356 (lambda (node)
1357 (cond ((cst? node))
1358 ((ref? node)
1359 (let ((var (ref-var node)))
1360 (mark-var! var)))
1361 ((def? node)
1362 (let ((var (def-var node))
1363 (val (child1 node)))
1364 (if (not (side-effect-less? val))
1365 (mark! val))))
1366 ((set? node)
1367 (let ((var (set-var node))
1368 (val (child1 node)))
1369 (mark! val)))
1370 ((if? node)
1371 (let ((a (list-ref (node-children node) 0))
1372 (b (list-ref (node-children node) 1))
1373 (c (list-ref (node-children node) 2)))
1374 (mark! a)
1375 (mark! b)
1376 (mark! c)))
1377 ((prc? node)
1378 (let ((body (list-ref (node-children node) 0)))
1379 (mark! body)))
1380 ((call? node)
1381 (for-each mark! (node-children node)))
1382 ((seq? node)
1383 (for-each mark! (node-children node)))
1384 (else
1385 (compiler-error "unknown expression type" node)))))
1387 (mark! node)
1388 ))
1390 ;-----------------------------------------------------------------------------
1392 ;; Variable sets
1394 (define (varset-empty) ; return the empty set
1395 '())
1397 (define (varset-singleton x) ; create a set containing only 'x'
1398 (list x))
1400 (define (list->varset lst) ; convert list to set
1401 lst)
1403 (define (varset->list set) ; convert set to list
1404 set)
1406 (define (varset-size set) ; return cardinality of set
1407 (list-length set))
1409 (define (varset-empty? set) ; is 'x' the empty set?
1410 (null? set))
1412 (define (varset-member? x set) ; is 'x' a member of the 'set'?
1413 (and (not (null? set))
1414 (or (eq? x (car set))
1415 (varset-member? x (cdr set)))))
1417 (define (varset-adjoin set x) ; add the element 'x' to the 'set'
1418 (if (varset-member? x set) set (cons x set)))
1420 (define (varset-remove set x) ; remove the element 'x' from 'set'
1421 (cond ((null? set)
1422 '())
1423 ((eq? (car set) x)
1424 (cdr set))
1425 (else
1426 (cons (car set) (varset-remove (cdr set) x)))))
1428 (define (varset-equal? s1 s2) ; are 's1' and 's2' equal sets?
1429 (and (varset-subset? s1 s2)
1430 (varset-subset? s2 s1)))
1432 (define (varset-subset? s1 s2) ; is 's1' a subset of 's2'?
1433 (cond ((null? s1)
1434 #t)
1435 ((varset-member? (car s1) s2)
1436 (varset-subset? (cdr s1) s2))
1437 (else
1438 #f)))
1440 (define (varset-difference set1 set2) ; return difference of sets
1441 (cond ((null? set1)
1442 '())
1443 ((varset-member? (car set1) set2)
1444 (varset-difference (cdr set1) set2))
1445 (else
1446 (cons (car set1) (varset-difference (cdr set1) set2)))))
1448 (define (varset-union set1 set2) ; return union of sets
1449 (define (union s1 s2)
1450 (cond ((null? s1)
1451 s2)
1452 ((varset-member? (car s1) s2)
1453 (union (cdr s1) s2))
1454 (else
1455 (cons (car s1) (union (cdr s1) s2)))))
1456 (if (varset-smaller? set1 set2)
1457 (union set1 set2)
1458 (union set2 set1)))
1460 (define (varset-intersection set1 set2) ; return intersection of sets
1461 (define (intersection s1 s2)
1462 (cond ((null? s1)
1463 '())
1464 ((varset-member? (car s1) s2)
1465 (cons (car s1) (intersection (cdr s1) s2)))
1466 (else
1467 (intersection (cdr s1) s2))))
1468 (if (varset-smaller? set1 set2)
1469 (intersection set1 set2)
1470 (intersection set2 set1)))
1472 (define (varset-intersects? set1 set2) ; do sets 'set1' and 'set2' intersect?
1473 (not (varset-empty? (varset-intersection set1 set2))))
1475 (define (varset-smaller? set1 set2)
1476 (if (null? set1)
1477 (not (null? set2))
1478 (if (null? set2)
1479 #f
1480 (varset-smaller? (cdr set1) (cdr set2)))))
1482 (define (varset-union-multi sets)
1483 (if (null? sets)
1484 (varset-empty)
1485 (n-ary varset-union (car sets) (cdr sets))))
1487 (define (n-ary function first rest)
1488 (if (null? rest)
1489 first
1490 (n-ary function (function first (car rest)) (cdr rest))))
1492 ;------------------------------------------------------------------------------
1494 (define code->vector
1495 (lambda (code)
1496 (let ((v (make-vector (+ (code-last-label code) 1))))
1497 (for-each
1498 (lambda (bb)
1499 (vector-set! v (bb-label bb) bb))
1500 (code-rev-bbs code))
1501 v)))
1503 (define bbs->ref-counts
1504 (lambda (bbs)
1505 (let ((ref-counts (make-vector (vector-length bbs) 0)))
1507 (define visit
1508 (lambda (label)
1509 (let ((ref-count (vector-ref ref-counts label)))
1510 (vector-set! ref-counts label (+ ref-count 1))
1511 (if (= ref-count 0)
1512 (let* ((bb (vector-ref bbs label))
1513 (rev-instrs (bb-rev-instrs bb)))
1514 (for-each
1515 (lambda (instr)
1516 (let ((opcode (car instr)))
1517 (cond ((eq? opcode 'goto)
1518 (visit (cadr instr)))
1519 ((eq? opcode 'goto-if-false)
1520 (visit (cadr instr))
1521 (visit (caddr instr)))
1522 ((or (eq? opcode 'closure)
1523 (eq? opcode 'call-toplevel)
1524 (eq? opcode 'jump-toplevel))
1525 (visit (cadr instr))))))
1526 rev-instrs))))))
1528 (visit 0)
1530 ref-counts)))
1532 (define resolve-toplevel-labels!
1533 (lambda (bbs)
1534 (let loop ((i 0))
1535 (if (< i (vector-length bbs))
1536 (let* ((bb (vector-ref bbs i))
1537 (rev-instrs (bb-rev-instrs bb)))
1538 (bb-rev-instrs-set!
1539 bb
1540 (map (lambda (instr)
1541 (let ((opcode (car instr)))
1542 (cond ((eq? opcode 'call-toplevel)
1543 (list opcode
1544 (prc-entry-label (cadr instr))))
1545 ((eq? opcode 'jump-toplevel)
1546 (list opcode
1547 (prc-entry-label (cadr instr))))
1548 (else
1549 instr))))
1550 rev-instrs))
1551 (loop (+ i 1)))))))
1553 (define tighten-jump-cascades!
1554 (lambda (bbs)
1555 (let ((ref-counts (bbs->ref-counts bbs)))
1557 (define resolve
1558 (lambda (label)
1559 (let* ((bb (vector-ref bbs label))
1560 (rev-instrs (bb-rev-instrs bb)))
1561 (and (or (null? (cdr rev-instrs))
1562 (= (vector-ref ref-counts label) 1))
1563 rev-instrs))))
1565 (let loop1 ()
1566 (let loop2 ((i 0)
1567 (changed? #f))
1568 (if (< i (vector-length bbs))
1569 (if (> (vector-ref ref-counts i) 0)
1570 (let* ((bb (vector-ref bbs i))
1571 (rev-instrs (bb-rev-instrs bb))
1572 (jump (car rev-instrs))
1573 (opcode (car jump)))
1574 (cond ((eq? opcode 'goto)
1575 (let* ((label (cadr jump))
1576 (jump-replacement (resolve label)))
1577 (if jump-replacement
1578 (begin
1579 (vector-set!
1580 bbs
1581 i
1582 (make-bb (bb-label bb)
1583 (append jump-replacement
1584 (cdr rev-instrs))))
1585 (loop2 (+ i 1)
1586 #t))
1587 (loop2 (+ i 1)
1588 changed?))))
1589 ((eq? opcode 'goto-if-false)
1590 (let* ((label-then (cadr jump))
1591 (label-else (caddr jump))
1592 (jump-then-replacement (resolve label-then))
1593 (jump-else-replacement (resolve label-else)))
1594 (if (and jump-then-replacement
1595 (null? (cdr jump-then-replacement))
1596 jump-else-replacement
1597 (null? (cdr jump-else-replacement))
1598 (or (eq? (caar jump-then-replacement) 'goto)
1599 (eq? (caar jump-else-replacement) 'goto)))
1600 (begin
1601 (vector-set!
1602 bbs
1603 i
1604 (make-bb (bb-label bb)
1605 (cons (list 'goto-if-false
1606 (if (eq? (caar jump-then-replacement) 'goto)
1607 (cadar jump-then-replacement)
1608 label-then)
1609 (if (eq? (caar jump-else-replacement) 'goto)
1610 (cadar jump-else-replacement)
1611 label-else))
1612 (cdr rev-instrs))))
1613 (loop2 (+ i 1)
1614 #t))
1615 (loop2 (+ i 1)
1616 changed?))))
1617 (else
1618 (loop2 (+ i 1)
1619 changed?))))
1620 (loop2 (+ i 1)
1621 changed?))
1622 (if changed?
1623 (loop1))))))))
1625 (define remove-useless-bbs!
1626 (lambda (bbs)
1627 (let ((ref-counts (bbs->ref-counts bbs)))
1628 (let loop1 ((label 0) (new-label 0))
1629 (if (< label (vector-length bbs))
1630 (if (> (vector-ref ref-counts label) 0)
1631 (let ((bb (vector-ref bbs label)))
1632 (vector-set!
1633 bbs
1634 label
1635 (make-bb new-label (bb-rev-instrs bb)))
1636 (loop1 (+ label 1) (+ new-label 1)))
1637 (loop1 (+ label 1) new-label))
1638 (renumber-labels bbs ref-counts new-label))))))
1640 (define renumber-labels
1641 (lambda (bbs ref-counts n)
1642 (let ((new-bbs (make-vector n)))
1643 (let loop2 ((label 0))
1644 (if (< label (vector-length bbs))
1645 (if (> (vector-ref ref-counts label) 0)
1646 (let* ((bb (vector-ref bbs label))
1647 (new-label (bb-label bb))
1648 (rev-instrs (bb-rev-instrs bb)))
1650 (define fix
1651 (lambda (instr)
1653 (define new-label
1654 (lambda (label)
1655 (bb-label (vector-ref bbs label))))
1657 (let ((opcode (car instr)))
1658 (cond ((eq? opcode 'closure)
1659 (list 'closure
1660 (new-label (cadr instr))))
1661 ((eq? opcode 'call-toplevel)
1662 (list 'call-toplevel
1663 (new-label (cadr instr))))
1664 ((eq? opcode 'jump-toplevel)
1665 (list 'jump-toplevel
1666 (new-label (cadr instr))))
1667 ((eq? opcode 'goto)
1668 (list 'goto
1669 (new-label (cadr instr))))
1670 ((eq? opcode 'goto-if-false)
1671 (list 'goto-if-false
1672 (new-label (cadr instr))
1673 (new-label (caddr instr))))
1674 (else
1675 instr)))))
1677 (vector-set!
1678 new-bbs
1679 new-label
1680 (make-bb new-label (map fix rev-instrs)))
1681 (loop2 (+ label 1)))
1682 (loop2 (+ label 1)))
1683 new-bbs)))))
1685 (define reorder!
1686 (lambda (bbs)
1687 (let* ((done (make-vector (vector-length bbs) #f)))
1689 (define unscheduled?
1690 (lambda (label)
1691 (not (vector-ref done label))))
1693 (define label-refs
1694 (lambda (instrs todo)
1695 (if (pair? instrs)
1696 (let* ((instr (car instrs))
1697 (opcode (car instr)))
1698 (cond ((or (eq? opcode 'closure)
1699 (eq? opcode 'call-toplevel)
1700 (eq? opcode 'jump-toplevel))
1701 (label-refs (cdr instrs) (cons (cadr instr) todo)))
1702 (else
1703 (label-refs (cdr instrs) todo))))
1704 todo)))
1706 (define schedule-here
1707 (lambda (label new-label todo cont)
1708 (let* ((bb (vector-ref bbs label))
1709 (rev-instrs (bb-rev-instrs bb))
1710 (jump (car rev-instrs))
1711 (opcode (car jump))
1712 (new-todo (label-refs rev-instrs todo)))
1713 (vector-set! bbs label (make-bb new-label rev-instrs))
1714 (vector-set! done label #t)
1715 (cond ((eq? opcode 'goto)
1716 (let ((label (cadr jump)))
1717 (if (unscheduled? label)
1718 (schedule-here label
1719 (+ new-label 1)
1720 new-todo
1721 cont)
1722 (cont (+ new-label 1)
1723 new-todo))))
1724 ((eq? opcode 'goto-if-false)
1725 (let ((label-then (cadr jump))
1726 (label-else (caddr jump)))
1727 (cond ((unscheduled? label-else)
1728 (schedule-here label-else
1729 (+ new-label 1)
1730 (cons label-then new-todo)
1731 cont))
1732 ((unscheduled? label-then)
1733 (schedule-here label-then
1734 (+ new-label 1)
1735 new-todo
1736 cont))
1737 (else
1738 (cont (+ new-label 1)
1739 new-todo)))))
1740 (else
1741 (cont (+ new-label 1)
1742 new-todo))))))
1744 (define schedule-somewhere
1745 (lambda (label new-label todo cont)
1746 (schedule-here label new-label todo cont)))
1748 (define schedule-todo
1749 (lambda (new-label todo)
1750 (if (pair? todo)
1751 (let ((label (car todo)))
1752 (if (unscheduled? label)
1753 (schedule-somewhere label
1754 new-label
1755 (cdr todo)
1756 schedule-todo)
1757 (schedule-todo new-label
1758 (cdr todo)))))))
1761 (schedule-here 0 0 '() schedule-todo)
1763 (renumber-labels bbs
1764 (make-vector (vector-length bbs) 1)
1765 (vector-length bbs)))))
1767 (define linearize
1768 (lambda (bbs)
1769 (let loop ((label (- (vector-length bbs) 1))
1770 (lst '()))
1771 (if (>= label 0)
1772 (let* ((bb (vector-ref bbs label))
1773 (rev-instrs (bb-rev-instrs bb))
1774 (jump (car rev-instrs))
1775 (opcode (car jump)))
1776 (loop (- label 1)
1777 (append
1778 (list label)
1779 (reverse
1780 (cond ((eq? opcode 'goto)
1781 (if (= (cadr jump) (+ label 1))
1782 (cdr rev-instrs)
1783 rev-instrs))
1784 ((eq? opcode 'goto-if-false)
1785 (cond ((= (caddr jump) (+ label 1))
1786 (cons (list 'goto-if-false (cadr jump))
1787 (cdr rev-instrs)))
1788 ((= (cadr jump) (+ label 1))
1789 (cons (list 'goto-if-not-false (caddr jump))
1790 (cdr rev-instrs)))
1791 (else
1792 (cons (list 'goto (caddr jump))
1793 (cons (list 'goto-if-false (cadr jump))
1794 (cdr rev-instrs))))))
1795 (else
1796 rev-instrs)))
1797 lst)))
1798 lst))))
1800 (define optimize-code
1801 (lambda (code)
1802 (let ((bbs (code->vector code)))
1803 (resolve-toplevel-labels! bbs)
1804 (tighten-jump-cascades! bbs)
1805 (let ((bbs (remove-useless-bbs! bbs)))
1806 (reorder! bbs)))))
1809 (define expand-loads
1810 (lambda (exprs)
1811 (map (lambda (e)
1812 (if (eq? (car e) 'load)
1813 (cons 'begin
1814 (expand-loads (with-input-from-file (cadr e) read-all)))
1815 e))
1816 exprs)))
1818 (define parse-file
1819 (lambda (filename)
1820 (let* ((library
1821 (with-input-from-file "library.scm" read-all))
1822 (toplevel-exprs
1823 (expand-loads (append library
1824 (with-input-from-file filename read-all))))
1825 (global-env
1826 (make-global-env))
1827 (parsed-prog
1828 (parse-top (cons 'begin toplevel-exprs) global-env)))
1830 (for-each
1831 (lambda (node)
1832 (mark-needed-global-vars! global-env node))
1833 parsed-prog)
1835 (extract-parts
1836 parsed-prog
1837 (lambda (defs after-defs)
1839 (define make-seq-preparsed
1840 (lambda (exprs)
1841 (let ((r (make-seq #f exprs)))
1842 (for-each (lambda (x) (node-parent-set! x r)) exprs)
1843 r)))
1845 (define make-call-preparsed
1846 (lambda (exprs)
1847 (let ((r (make-call #f exprs)))
1848 (for-each (lambda (x) (node-parent-set! x r)) exprs)
1849 r)))
1851 (if (var-needed?
1852 (env-lookup global-env '#%readyq))
1853 (make-seq-preparsed
1854 (list (make-seq-preparsed defs)
1855 (make-call-preparsed
1856 (list (parse 'value '#%start-first-process global-env)
1857 (let* ((pattern
1858 '())
1859 (ids
1860 (extract-ids pattern))
1861 (r
1862 (make-prc #f '() #f (has-rest-param? pattern) #f))
1863 (new-env
1864 (env-extend global-env ids r))
1865 (body
1866 (make-seq-preparsed after-defs)))
1867 (prc-params-set!
1868 r
1869 (map (lambda (id) (env-lookup new-env id))
1870 ids))
1871 (node-children-set! r (list body))
1872 (node-parent-set! body r)
1873 r)))
1874 (parse 'value
1875 '(#%exit)
1876 global-env)))
1877 (make-seq-preparsed
1878 (append defs
1879 after-defs
1880 (list (parse 'value
1881 '(#%halt)
1882 global-env))))))))))
1884 (define extract-parts
1885 (lambda (lst cont)
1886 (if (or (null? lst)
1887 (not (def? (car lst))))
1888 (cont '() lst)
1889 (extract-parts
1890 (cdr lst)
1891 (lambda (d ad)
1892 (cont (cons (car lst) d) ad))))))
1894 ;------------------------------------------------------------------------------
1896 ;;(include "asm.scm")
1898 ;;; File: "asm.scm"
1899 ;;;
1900 ;;; This module implements the generic assembler.
1902 ;;(##declare (standard-bindings) (fixnum) (block))
1904 (define compiler-internal-error error)
1906 ;; (asm-begin! start-pos big-endian?) initializes the assembler and
1907 ;; starts a new empty code stream at address "start-pos". It must be
1908 ;; called every time a new code stream is to be built. The argument
1909 ;; "big-endian?" indicates the byte ordering to use for 16, 32 and 64
1910 ;; bit values. After a call to "asm-begin!" the code stream is built
1911 ;; by calling the following procedures:
1912 ;;
1913 ;; asm-8 to add an 8 bit integer to the code stream
1914 ;; asm-16 to add a 16 bit integer to the code stream
1915 ;; asm-32 to add a 32 bit integer to the code stream
1916 ;; asm-64 to add a 64 bit integer to the code stream
1917 ;; asm-float64 to add a 64 bit IEEE float to the code stream
1918 ;; asm-string to add a null terminated string to the code stream
1919 ;; asm-label to set a label to the current position in the code stream
1920 ;; asm-align to add enough zero bytes to force alignment
1921 ;; asm-origin to add enough zero bytes to move to a particular address
1922 ;; asm-at-assembly to defer code production to assembly time
1923 ;; asm-listing to add textual information to the listing
1925 (define (asm-begin! start-pos big-endian?)
1926 (set! asm-start-pos start-pos)
1927 (set! asm-big-endian? big-endian?)
1928 (set! asm-code-stream (asm-make-stream))
1929 #f)
1931 ;; (asm-end!) must be called to finalize the assembler.
1933 (define (asm-end!)
1934 (set! asm-code-stream #f)
1935 #f)
1937 ;; (asm-8 n) adds an 8 bit signed or unsigned integer to the code stream.
1939 (define (asm-8 n)
1940 (asm-code-extend (asm-bits-0-to-7 n)))
1942 ;; (asm-16 n) adds a 16 bit signed or unsigned integer to the code stream.
1944 (define (asm-16 n)
1945 (if asm-big-endian?
1946 (begin (asm-8 (asm-bits-8-and-up n)) (asm-8 n))
1947 (begin (asm-8 n) (asm-8 (asm-bits-8-and-up n)))))
1949 ;; (asm-32 n) adds a 32 bit signed or unsigned integer to the code stream.
1951 (define (asm-32 n)
1952 (if asm-big-endian?
1953 (begin (asm-16 (asm-bits-16-and-up n)) (asm-16 n))
1954 (begin (asm-16 n) (asm-16 (asm-bits-16-and-up n)))))
1956 ;; (asm-64 n) adds a 64 bit signed or unsigned integer to the code stream.
1958 (define (asm-64 n)
1959 (if asm-big-endian?
1960 (begin (asm-32 (asm-bits-32-and-up n)) (asm-32 n))
1961 (begin (asm-32 n) (asm-32 (asm-bits-32-and-up n)))))
1963 ;; (asm-float64 n) adds a 64 bit IEEE floating point number to the code stream.
1965 (define (asm-float64 n)
1966 (asm-64 (asm-float->bits n)))
1968 ;; (asm-string str) adds a null terminated string to the code stream.
1970 (define (asm-string str)
1971 (let ((len (string-length str)))
1972 (let loop ((i 0))
1973 (if (< i len)
1974 (begin
1975 (asm-8 (char->integer (string-ref str i)))
1976 (loop (+ i 1)))
1977 (asm-8 0)))))
1979 ;; (asm-make-label id) creates a new label object. A label can
1980 ;; be queried with "asm-label-pos" to obtain the label's position
1981 ;; relative to the start of the code stream (i.e. "start-pos").
1982 ;; The argument "id" gives a name to the label (not necessarily
1983 ;; unique) and is only needed for debugging purposes.
1985 (define (asm-make-label id)
1986 (vector 'LABEL #f id))
1988 ;; (asm-label label-obj) sets the label to the current position in the
1989 ;; code stream.
1991 (define (asm-label label-obj)
1992 (if (vector-ref label-obj 1)
1993 (compiler-internal-error
1994 "asm-label, label multiply defined" (asm-label-id label-obj))
1995 (begin
1996 (vector-set! label-obj 1 0)
1997 (asm-code-extend label-obj))))
1999 ;; (asm-label-id label-obj) returns the identifier of the label object.
2001 (define (asm-label-id label-obj)
2002 (vector-ref label-obj 2))
2004 ;; (asm-label-pos label-obj) returns the position of the label
2005 ;; relative to the start of the code stream (i.e. "start-pos").
2006 ;; This procedure can only be called at assembly time (i.e.
2007 ;; within the call to "asm-assemble") or after assembly time
2008 ;; for labels declared prior to assembly time with "asm-label".
2009 ;; A label declared at assembly time can only be queried after
2010 ;; assembly time. Moreover, at assembly time the position of a
2011 ;; label may vary from one call to the next due to the actions
2012 ;; of the assembler.
2014 (define (asm-label-pos label-obj)
2015 (let ((pos (vector-ref label-obj 1)))
2016 (if pos
2017 pos
2018 (compiler-internal-error
2019 "asm-label-pos, undefined label" (asm-label-id label-obj)))))
2021 ;; (asm-align multiple offset) adds enough zero bytes to the code
2022 ;; stream to force alignment to the next address congruent to
2023 ;; "offset" modulo "multiple".
2025 (define (asm-align multiple offset)
2026 (asm-at-assembly
2027 (lambda (self)
2028 (modulo (- multiple (- self offset)) multiple))
2029 (lambda (self)
2030 (let loop ((n (modulo (- multiple (- self offset)) multiple)))
2031 (if (> n 0)
2032 (begin
2033 (asm-8 0)
2034 (loop (- n 1))))))))
2036 ;; (asm-origin address) adds enough zero bytes to the code stream to move
2037 ;; to the address "address".
2039 (define (asm-origin address)
2040 (asm-at-assembly
2041 (lambda (self)
2042 (- address self))
2043 (lambda (self)
2044 (let ((len (- address self)))
2045 (if (< len 0)
2046 (compiler-internal-error "asm-origin, can't move back")
2047 (let loop ((n len))
2048 (if (> n 0)
2049 (begin
2050 (asm-8 0)
2051 (loop (- n 1))))))))))
2053 ;; (asm-at-assembly . procs) makes it possible to defer code
2054 ;; production to assembly time. A useful application is to generate
2055 ;; position dependent and span dependent code sequences. This
2056 ;; procedure must be passed an even number of procedures. All odd
2057 ;; indexed procedures (including the first procedure) are called "check"
2058 ;; procedures. The even indexed procedures are the "production"
2059 ;; procedures which, when called, produce a particular code sequence.
2060 ;; A check procedure decides if, given the current state of assembly
2061 ;; (in particular the current positioning of the labels), the code
2062 ;; produced by the corresponding production procedure is valid.
2063 ;; If the code is not valid, the check procedure must return #f.
2064 ;; If the code is valid, the check procedure must return the length
2065 ;; of the code sequence in bytes. The assembler will try each check
2066 ;; procedure in order until it finds one that does not return #f
2067 ;; (the last check procedure must never return #f). For convenience,
2068 ;; the current position in the code sequence is passed as the single
2069 ;; argument of check and production procedures.
2070 ;;
2071 ;; Here is a sample call of "asm-at-assembly" to produce the
2072 ;; shortest branch instruction to branch to label "x" for a
2073 ;; hypothetical processor:
2074 ;;
2075 ;; (asm-at-assembly
2076 ;;
2077 ;; (lambda (self) ; first check procedure
2078 ;; (let ((dist (- (asm-label-pos x) self)))
2079 ;; (if (and (>= dist -128) (<= dist 127)) ; short branch possible?
2080 ;; 2
2081 ;; #f)))
2082 ;;
2083 ;; (lambda (self) ; first production procedure
2084 ;; (asm-8 #x34) ; branch opcode for 8 bit displacement
2085 ;; (asm-8 (- (asm-label-pos x) self)))
2086 ;;
2087 ;; (lambda (self) 5) ; second check procedure
2088 ;;
2089 ;; (lambda (self) ; second production procedure
2090 ;; (asm-8 #x35) ; branch opcode for 32 bit displacement
2091 ;; (asm-32 (- (asm-label-pos x) self))))
2093 (define (asm-at-assembly . procs)
2094 (asm-code-extend (vector 'DEFERRED procs)))
2096 ;; (asm-listing text) adds text to the right side of the listing.
2097 ;; The atoms in "text" will be output using "display" (lists are
2098 ;; traversed recursively). The listing is generated by calling
2099 ;; "asm-display-listing".
2101 (define (asm-listing text)
2102 (asm-code-extend (vector 'LISTING text)))
2104 ;; (asm-assemble) assembles the code stream. After assembly, the
2105 ;; label objects will be set to their final position and the
2106 ;; alignment bytes and the deferred code will have been produced. It
2107 ;; is possible to extend the code stream after assembly. However, if
2108 ;; any of the procedures "asm-label", "asm-align", and
2109 ;; "asm-at-assembly" are called, the code stream will have to be
2110 ;; assembled once more.
2112 (define (asm-assemble)
2113 (let ((fixup-lst (asm-pass1)))
2115 (let loop1 ()
2116 (let loop2 ((lst fixup-lst)
2117 (changed? #f)
2118 (pos asm-start-pos))
2119 (if (null? lst)
2120 (if changed? (loop1))
2121 (let* ((fixup (car lst))
2122 (pos (+ pos (car fixup)))
2123 (curr (cdr fixup))
2124 (x (car curr)))
2125 (if (eq? (vector-ref x 0) 'LABEL)
2126 ; LABEL
2127 (if (= (vector-ref x 1) pos)
2128 (loop2 (cdr lst) changed? pos)
2129 (begin
2130 (vector-set! x 1 pos)
2131 (loop2 (cdr lst) #t pos)))
2132 ; DEFERRED
2133 (let loop3 ()
2134 (let ((n ((car (vector-ref x 1)) pos)))
2135 (if n
2136 (loop2 (cdr lst) changed? (+ pos n))
2137 (begin
2138 (vector-set! x 1 (cddr (vector-ref x 1)))
2139 (loop3))))))))))
2141 (let loop4 ((prev asm-code-stream)
2142 (curr (cdr asm-code-stream))
2143 (pos asm-start-pos))
2144 (if (null? curr)
2145 (set-car! asm-code-stream prev)
2146 (let ((x (car curr))
2147 (next (cdr curr)))
2148 (if (vector? x)
2149 (let ((kind (vector-ref x 0)))
2150 (cond ((eq? kind 'LABEL)
2151 (let ((final-pos (vector-ref x 1)))
2152 (if final-pos
2153 (if (not (= pos final-pos))
2154 (compiler-internal-error
2155 "asm-assemble, inconsistency detected"))
2156 (vector-set! x 1 pos))
2157 (set-cdr! prev next)
2158 (loop4 prev next pos)))
2159 ((eq? kind 'DEFERRED)
2160 (let ((temp asm-code-stream))
2161 (set! asm-code-stream (asm-make-stream))
2162 ((cadr (vector-ref x 1)) pos)
2163 (let ((tail (car asm-code-stream)))
2164 (set-cdr! tail next)
2165 (let ((head (cdr asm-code-stream)))
2166 (set-cdr! prev head)
2167 (set! asm-code-stream temp)
2168 (loop4 prev head pos)))))
2169 (else
2170 (loop4 curr next pos))))
2171 (loop4 curr next (+ pos 1))))))))
2173 ;; (asm-display-listing port) produces a listing of the code stream
2174 ;; on the given output port. The bytes generated are shown in
2175 ;; hexadecimal on the left side of the listing and the right side
2176 ;; of the listing contains the text inserted by "asm-listing".
2178 (define (asm-display-listing port)
2180 (define text-col 24)
2181 (define pos-width 6)
2182 (define byte-width 2)
2184 (define (output text)
2185 (cond ((null? text))
2186 ((pair? text)
2187 (output (car text))
2188 (output (cdr text)))
2189 (else
2190 (display text port))))
2192 (define (print-hex n)
2193 (display (string-ref "0123456789ABCDEF" n) port))
2195 (define (print-byte n)
2196 (print-hex (quotient n 16))
2197 (print-hex (modulo n 16)))
2199 (define (print-pos n)
2200 (if (< n 0)
2201 (display " " port)
2202 (begin
2203 (print-byte (quotient n #x10000))
2204 (print-byte (modulo (quotient n #x100) #x100))
2205 (print-byte (modulo n #x100)))))
2207 (let loop1 ((lst (cdr asm-code-stream)) (pos asm-start-pos) (col 0))
2208 (if (null? lst)
2209 (if (> col 0)
2210 (newline port))
2211 (let ((x (car lst)))
2212 (if (vector? x)
2213 (let ((kind (vector-ref x 0)))
2214 (cond ((eq? kind 'LISTING)
2215 (let loop2 ((col col))
2216 (if (< col text-col)
2217 (begin
2218 (display (integer->char 9) port)
2219 (loop2 (* 8 (+ (quotient col 8) 1))))))
2220 (output (vector-ref x 1))
2221 (newline port)
2222 (loop1 (cdr lst) pos 0))
2223 (else
2224 (compiler-internal-error
2225 "asm-display-listing, code stream not assembled"))))
2226 (if (or (= col 0) (>= col (- text-col byte-width)))
2227 (begin
2228 (if (not (= col 0)) (newline port))
2229 (print-pos pos)
2230 (display " " port)
2231 (print-byte x)
2232 (loop1 (cdr lst) (+ pos 1) (+ (+ pos-width 1) byte-width)))
2233 (begin
2234 (print-byte x)
2235 (loop1 (cdr lst) (+ pos 1) (+ col byte-width)))))))))
2237 ;; (asm-write-code filename) outputs the code stream (i.e. the sequence
2238 ;; of bytes produced) on the named file.
2240 (define (asm-write-code filename)
2241 (with-output-to-file filename
2242 (lambda ()
2243 (let loop ((lst (cdr asm-code-stream)))
2244 (if (not (null? lst))
2245 (let ((x (car lst)))
2246 (if (vector? x)
2247 (let ((kind (vector-ref x 0)))
2248 (if (not (eq? kind 'LISTING))
2249 (compiler-internal-error
2250 "asm-write-code, code stream not assembled"))
2251 (loop (cdr lst)))
2252 (begin
2253 (write-char (integer->char x))
2254 (loop (cdr lst))))))))))
2256 (define (asm-write-hex-file filename)
2257 (with-output-to-file filename
2258 (lambda ()
2260 (define (print-hex n)
2261 (display (string-ref "0123456789ABCDEF" n)))
2263 (define (print-byte n)
2264 (print-hex (quotient n 16))
2265 (print-hex (modulo n 16)))
2267 (define (print-line type addr bytes)
2268 (let ((n (length bytes))
2269 (addr-hi (quotient addr 256))
2270 (addr-lo (modulo addr 256)))
2271 (display ":")
2272 (print-byte n)
2273 (print-byte addr-hi)
2274 (print-byte addr-lo)
2275 (print-byte type)
2276 (for-each print-byte bytes)
2277 (let ((sum
2278 (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
2279 (print-byte sum)
2280 (newline))))
2282 (let loop ((lst (cdr asm-code-stream))
2283 (pos asm-start-pos)
2284 (rev-bytes '()))
2285 (if (not (null? lst))
2286 (let ((x (car lst)))
2287 (if (vector? x)
2288 (let ((kind (vector-ref x 0)))
2289 (if (not (eq? kind 'LISTING))
2290 (compiler-internal-error
2291 "asm-write-hex-file, code stream not assembled"))
2292 (loop (cdr lst)
2293 pos
2294 rev-bytes))
2295 (let ((new-pos
2296 (+ pos 1))
2297 (new-rev-bytes
2298 (cons x
2299 (if (= (modulo pos 16) 0)
2300 (begin
2301 (print-line 0
2302 (- pos (length rev-bytes))
2303 (reverse rev-bytes))
2304 '())
2305 rev-bytes))))
2306 (loop (cdr lst)
2307 new-pos
2308 new-rev-bytes))))
2309 (begin
2310 (if (not (null? rev-bytes))
2311 (print-line 0
2312 (- pos (length rev-bytes))
2313 (reverse rev-bytes)))
2314 (print-line 1 0 '())
2315 (if #t
2316 (begin
2317 (display (- pos asm-start-pos) ##stderr-port)
2318 (display " bytes\n" ##stderr-port)))))))))
2320 ;; Utilities.
2322 (define asm-start-pos #f) ; start position of the code stream
2323 (define asm-big-endian? #f) ; endianness to use
2324 (define asm-code-stream #f) ; current code stream
2326 (define (asm-make-stream) ; create an empty stream
2327 (let ((x (cons '() '())))
2328 (set-car! x x)
2329 x))
2331 (define (asm-code-extend item) ; add an item at the end of current code stream
2332 (let* ((stream asm-code-stream)
2333 (tail (car stream))
2334 (cell (cons item '())))
2335 (set-cdr! tail cell)
2336 (set-car! stream cell)))
2338 (define (asm-pass1) ; construct fixup list and make first label assignment
2339 (let loop ((curr (cdr asm-code-stream))
2340 (fixup-lst '())
2341 (span 0)
2342 (pos asm-start-pos))
2343 (if (null? curr)
2344 (reverse fixup-lst)
2345 (let ((x (car curr)))
2346 (if (vector? x)
2347 (let ((kind (vector-ref x 0)))
2348 (cond ((eq? kind 'LABEL)
2349 (vector-set! x 1 pos) ; first approximation of position
2350 (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
2351 ((eq? kind 'DEFERRED)
2352 (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
2353 (else
2354 (loop (cdr curr) fixup-lst span pos))))
2355 (loop (cdr curr) fixup-lst (+ span 1) (+ pos 1)))))))
2357 ;(##declare (generic))
2359 (define (asm-bits-0-to-7 n) ; return bits 0 to 7 of a signed integer
2360 (modulo n #x100))
2362 (define (asm-bits-8-and-up n) ; return bits 8 and up of a signed integer
2363 (if (>= n 0)
2364 (quotient n #x100)
2365 (- (quotient (+ n 1) #x100) 1)))
2367 (define (asm-bits-16-and-up n) ; return bits 16 and up of a signed integer
2368 (if (>= n 0)
2369 (quotient n #x10000)
2370 (- (quotient (+ n 1) #x10000) 1)))
2372 (define (asm-bits-32-and-up n) ; return bits 32 and up of a signed integer
2373 (if (>= n 0)
2374 (quotient n #x100000000)
2375 (- (quotient (+ n 1) #x100000000) 1)))
2377 ; The following procedures convert floating point numbers into their
2378 ; machine representation. They perform bignum and flonum arithmetic.
2380 (define (asm-float->inexact-exponential-format x)
2382 (define (exp-form-pos x y i)
2383 (let ((i*2 (+ i i)))
2384 (let ((z (if (and (not (< asm-ieee-e-bias i*2))
2385 (not (< x y)))
2386 (exp-form-pos x (* y y) i*2)
2387 (cons x 0))))
2388 (let ((a (car z)) (b (cdr z)))
2389 (let ((i+b (+ i b)))
2390 (if (and (not (< asm-ieee-e-bias i+b))
2391 (not (< a y)))
2392 (begin
2393 (set-car! z (/ a y))
2394 (set-cdr! z i+b)))
2395 z)))))
2397 (define (exp-form-neg x y i)
2398 (let ((i*2 (+ i i)))
2399 (let ((z (if (and (< i*2 asm-ieee-e-bias-minus-1)
2400 (< x y))
2401 (exp-form-neg x (* y y) i*2)
2402 (cons x 0))))
2403 (let ((a (car z)) (b (cdr z)))
2404 (let ((i+b (+ i b)))
2405 (if (and (< i+b asm-ieee-e-bias-minus-1)
2406 (< a y))
2407 (begin
2408 (set-car! z (/ a y))
2409 (set-cdr! z i+b)))
2410 z)))))
2412 (define (exp-form x)
2413 (if (< x asm-inexact-+1)
2414 (let ((z (exp-form-neg x asm-inexact-+1/2 1)))
2415 (set-car! z (* asm-inexact-+2 (car z)))
2416 (set-cdr! z (- -1 (cdr z)))
2417 z)
2418 (exp-form-pos x asm-inexact-+2 1)))
2420 (if (negative? x)
2421 (let ((z (exp-form (- asm-inexact-0 x))))
2422 (set-car! z (- asm-inexact-0 (car z)))
2423 z)
2424 (exp-form x)))
2426 (define (asm-float->exact-exponential-format x)
2427 (let ((z (asm-float->inexact-exponential-format x)))
2428 (let ((y (car z)))
2429 (cond ((not (< y asm-inexact-+2))
2430 (set-car! z asm-ieee-+m-min)
2431 (set-cdr! z asm-ieee-e-bias-plus-1))
2432 ((not (< asm-inexact--2 y))
2433 (set-car! z asm-ieee--m-min)
2434 (set-cdr! z asm-ieee-e-bias-plus-1))
2435 (else
2436 (set-car! z
2437 (truncate (inexact->exact (* (car z) asm-inexact-m-min))))))
2438 (set-cdr! z (- (cdr z) asm-ieee-m-bits))
2439 z)))
2441 (define (asm-float->bits x) ; returns the 64 bit integer encoding the float "x"
2443 (define (bits a b)
2444 (if (< a asm-ieee-+m-min)
2445 a
2446 (+ (- a asm-ieee-+m-min)
2447 (* (+ (+ b asm-ieee-m-bits) asm-ieee-e-bias)
2448 asm-ieee-+m-min))))
2450 (let ((z (asm-float->exact-exponential-format x)))
2451 (let ((a (car z)) (b (cdr z)))
2452 (if (negative? a)
2453 (+ asm-ieee-sign-bit (bits (- 0 a) b))
2454 (bits a b)))))
2456 ; Parameters for ANSI-IEEE Std 754-1985 representation of
2457 ; doubles (i.e. 64 bit floating point numbers):
2459 (define asm-ieee-m-bits 52)
2460 (define asm-ieee-e-bits 11)
2461 (define asm-ieee-+m-min 4503599627370496) ; (expt 2 asm-ieee-m-bits)
2462 (define asm-ieee--m-min -4503599627370496) ; (- asm-ieee-+m-min)
2463 (define asm-ieee-sign-bit #x8000000000000000); (expt 2 (+ asm-ieee-e-bits asm-ieee-m-bits))
2465 (define asm-ieee-e-bias 1023) ; (- (expt 2 (- asm-ieee-e-bits 1)) 1)
2466 (define asm-ieee-e-bias-plus-1 1024) ; (+ asm-ieee-e-bias 1)
2467 (define asm-ieee-e-bias-minus-1 1022) ; (- asm-ieee-e-bias 1)
2469 (define asm-inexact-m-min (exact->inexact asm-ieee-+m-min))
2470 (define asm-inexact-+2 (exact->inexact 2))
2471 (define asm-inexact--2 (exact->inexact -2))
2472 (define asm-inexact-+1 (exact->inexact 1))
2473 (define asm-inexact-+1/2 (exact->inexact (/ 1 2)))
2474 (define asm-inexact-0 (exact->inexact 0))
2476 ;------------------------------------------------------------------------------
2478 (define min-fixnum-encoding 3)
2479 (define min-fixnum 0)
2480 (define max-fixnum 255)
2481 (define min-rom-encoding (+ min-fixnum-encoding (- max-fixnum min-fixnum) 1))
2482 (define min-ram-encoding 512)
2483 (define max-ram-encoding 4095)
2484 (define min-vec-encoding 4096)
2485 (define max-vec-encoding 8191)
2487 (define code-start #x5000)
2489 (define (predef-constants) (list))
2491 (define (predef-globals) (list))
2493 (define (encode-direct obj)
2494 (cond ((eq? obj #f)
2495 0)
2496 ((eq? obj #t)
2497 1)
2498 ((eq? obj '())
2499 2)
2500 ((and (integer? obj)
2501 (exact? obj)
2502 (>= obj min-fixnum)
2503 (<= obj max-fixnum))
2504 (+ obj (- min-fixnum-encoding min-fixnum)))
2505 (else
2506 #f)))
2508 (define (translate-constant obj)
2509 (if (char? obj)
2510 (char->integer obj)
2511 obj))
2513 (define (encode-constant obj constants)
2514 (let ((o (translate-constant obj)))
2515 (let ((e (encode-direct o)))
2516 (if e
2517 e
2518 (let ((x (assoc o constants))) ;; TODO was assq
2519 (if x
2520 (vector-ref (cdr x) 0)
2521 (compiler-error "unknown object" obj)))))))
2523 (define (add-constant obj constants from-code? cont)
2524 (let ((o (translate-constant obj)))
2525 (let ((e (encode-direct o)))
2526 (if e
2527 (cont constants)
2528 (let ((x (assoc o constants))) ;; TODO was assq
2529 (if x
2530 (begin
2531 (if from-code?
2532 (vector-set! (cdr x) 2 (+ (vector-ref (cdr x) 2) 1)))
2533 (cont constants))
2534 (let* ((descr
2535 (vector #f
2536 (asm-make-label 'constant)
2537 (if from-code? 1 0)
2538 #f))
2539 (new-constants
2540 (cons (cons o descr)
2541 constants)))
2542 (cond ((pair? o) ;; TODO what to do in the case of a pair of, for example, fixnums, where only one object is actually used ?
2543 (add-constants (list (car o) (cdr o))
2544 new-constants
2545 cont))
2546 ((symbol? o)
2547 (cont new-constants))
2548 ((string? o)
2549 (let ((chars (map char->integer (string->list o))))
2550 (vector-set! descr 3 chars)
2551 (add-constant chars
2552 new-constants
2553 #f
2554 cont)))
2555 ((vector? o)
2556 (let ((elems (vector->list o)))
2557 (vector-set! descr 3 elems)
2558 (add-constant elems
2559 new-constants
2560 #f
2561 cont)))
2562 ((u8vector? o) ;; NEW, for now they are lists
2563 (let ((elems (u8vector->list o)))
2564 (vector-set! descr 3 elems)
2565 (add-constant elems
2566 new-constants
2567 #f
2568 cont)))
2569 (else
2570 (cont new-constants))))))))))
2572 (define (add-constants objs constants cont)
2573 (if (null? objs)
2574 (cont constants)
2575 (add-constant (car objs)
2576 constants
2577 #f
2578 (lambda (new-constants)
2579 (add-constants (cdr objs)
2580 new-constants
2581 cont)))))
2583 (define (add-global var globals cont)
2584 (let ((x (assq var globals)))
2585 (if x
2586 (cont globals)
2587 (let ((new-globals
2588 (cons (cons var (length globals))
2589 globals)))
2590 (cont new-globals)))))
2592 (define (sort-constants constants)
2593 (let ((csts
2594 (sort-list constants
2595 (lambda (x y)
2596 (> (vector-ref (cdr x) 2)
2597 (vector-ref (cdr y) 2))))))
2598 (let loop ((i min-rom-encoding)
2599 (lst csts))
2600 (if (null? lst)
2601 (if (> i min-ram-encoding)
2602 (compiler-error "too many constants")
2603 csts)
2604 (begin
2605 (vector-set! (cdr (car lst)) 0 i)
2606 (loop (+ i 1)
2607 (cdr lst)))))))
2609 (define assemble
2610 (lambda (code hex-filename)
2611 (let loop1 ((lst code)
2612 (constants (predef-constants))
2613 (globals (predef-globals))
2614 (labels (list)))
2615 (if (pair? lst)
2617 (let ((instr (car lst)))
2618 (cond ((number? instr)
2619 (loop1 (cdr lst)
2620 constants
2621 globals
2622 (cons (cons instr (asm-make-label 'label))
2623 labels)))
2624 ((eq? (car instr) 'push-constant)
2625 (add-constant (cadr instr)
2626 constants
2627 #t
2628 (lambda (new-constants)
2629 (loop1 (cdr lst)
2630 new-constants
2631 globals
2632 labels))))
2633 ((memq (car instr) '(push-global set-global))
2634 (add-global (cadr instr)
2635 globals
2636 (lambda (new-globals)
2637 (loop1 (cdr lst)
2638 constants
2639 new-globals
2640 labels))))
2641 (else
2642 (loop1 (cdr lst)
2643 constants
2644 globals
2645 labels))))
2647 (let ((constants (sort-constants constants)))
2649 (define (label-instr label opcode)
2650 (asm-at-assembly
2651 (lambda (self)
2652 3)
2653 (lambda (self)
2654 (let ((pos (- (asm-label-pos label) code-start)))
2655 (asm-8 opcode)
2656 (asm-8 (quotient pos 256))
2657 (asm-8 (modulo pos 256))))))
2659 (define (push-constant n)
2660 (if (<= n 31)
2661 (asm-8 (+ #x00 n))
2662 (begin
2663 (asm-8 #xfc)
2664 (asm-8 (quotient n 256)) ;; BREGG this is a test, the compiler cannot know about anything over 256 (as long as no rom goes higher, which might change, watch out for this), so no need for 13 bits OOPS, actually, 8 is not enough for fixnums and rom, revert to 12 and use some of the free instrs ?
2665 (asm-8 (modulo n 256))))) ;; TODO with 13-bit objects, we need 2 bytes, maybe limit to 12, so we could use a byte and a half, but we'd need to use an opcode with only 4 bits, maybe the call/jump stuff can be combined ? FOOBAR
2667 (define (push-stack n)
2668 (if (> n 31)
2669 (compiler-error "stack is too deep")
2670 (asm-8 (+ #x20 n))))
2672 (define (push-global n)
2673 (asm-8 (+ #x40 n)) ;; TODO maybe do the same as for csts, have a push-long-global to have more ?
2674 ;; (if (> n 15)
2675 ;; (compiler-error "too many global variables")
2676 ;; (asm-8 (+ #x40 n)))
2677 ) ;; TODO actually inline most, or put as csts
2679 (define (set-global n)
2680 (asm-8 (+ #x50 n))
2681 ;; (if (> n 15) ;; ADDED prevented the stack from compiling
2682 ;; (compiler-error "too many global variables")
2683 ;; (asm-8 (+ #x50 n)))
2684 )
2686 (define (call n)
2687 (if (> n 15)
2688 (compiler-error "call has too many arguments")
2689 (asm-8 (+ #x60 n))))
2691 (define (jump n)
2692 (if (> n 15)
2693 (compiler-error "call has too many arguments")
2694 (asm-8 (+ #x70 n))))
2696 (define (call-toplevel label) ;; TODO use 8-bit opcodes for these
2697 (label-instr label #x80))
2699 (define (jump-toplevel label)
2700 (label-instr label #x90))
2702 (define (goto label)
2703 (label-instr label #xa0))
2705 (define (goto-if-false label)
2706 (label-instr label #xb0))
2708 (define (closure label)
2709 (label-instr label #xc0)) ;; FOOBAR change here ?
2711 (define (prim n)
2712 (asm-8 (+ #xd0 n)))
2714 (define (prim.number?) (prim 0))
2715 (define (prim.+) (prim 1))
2716 (define (prim.-) (prim 2))
2717 (define (prim.*) (prim 3))
2718 (define (prim.quotient) (prim 4))
2719 (define (prim.remainder) (prim 5))
2720 (define (prim.neg) (prim 6))
2721 (define (prim.=) (prim 7))
2722 (define (prim.<) (prim 8))
2723 (define (prim.ior) (prim 9))
2724 (define (prim.>) (prim 10))
2725 (define (prim.xor) (prim 11))
2726 (define (prim.pair?) (prim 12))
2727 (define (prim.cons) (prim 13))
2728 (define (prim.car) (prim 14))
2729 (define (prim.cdr) (prim 15))
2730 (define (prim.set-car!) (prim 16))
2731 (define (prim.set-cdr!) (prim 17))
2732 (define (prim.null?) (prim 18))
2733 (define (prim.eq?) (prim 19))
2734 (define (prim.not) (prim 20))
2735 (define (prim.get-cont) (prim 21))
2736 (define (prim.graft-to-cont) (prim 22))
2737 (define (prim.return-to-cont) (prim 23))
2738 (define (prim.halt) (prim 24))
2739 (define (prim.symbol?) (prim 25))
2740 (define (prim.string?) (prim 26))
2741 (define (prim.string->list) (prim 27))
2742 (define (prim.list->string) (prim 28))
2744 (define (prim.make-u8vector) (prim 29))
2745 (define (prim.u8vector-ref) (prim 30))
2746 (define (prim.u8vector-set!) (prim 31))
2748 (define (prim.print) (prim 32))
2749 (define (prim.clock) (prim 33))
2750 (define (prim.motor) (prim 34))
2751 (define (prim.led) (prim 35))
2752 (define (prim.led2-color) (prim 36))
2753 (define (prim.getchar-wait) (prim 37))
2754 (define (prim.putchar) (prim 38))
2755 (define (prim.beep) (prim 39))
2756 (define (prim.adc) (prim 40))
2757 (define (prim.u8vector?) (prim 41)) ;; TODO was dac
2758 (define (prim.sernum) (prim 42)) ;; TODO necessary ?
2759 (define (prim.u8vector-length) (prim 43))
2761 (define (prim.shift) (prim 45))
2762 (define (prim.pop) (prim 46))
2763 (define (prim.return) (prim 47))
2765 (define big-endian? #f)
2767 (asm-begin! code-start #f)
2769 (asm-8 #xfb)
2770 (asm-8 #xd7)
2771 (asm-8 (length constants))
2772 (asm-8 0)
2774 (pp (list constants: constants globals: globals)) ;; TODO debug
2776 (for-each
2777 (lambda (x)
2778 (let* ((descr (cdr x))
2779 (label (vector-ref descr 1))
2780 (obj (car x)))
2781 (asm-label label)
2782 ;; see the vm source for a description of encodings
2783 (cond ((and (integer? obj) (exact? obj))
2784 (asm-8 0)
2785 (asm-8 (bitwise-and (arithmetic-shift obj -16) 255))
2786 (asm-8 (bitwise-and (arithmetic-shift obj -8) 255))
2787 (asm-8 (bitwise-and obj 255)))
2788 ((pair? obj)
2789 (let ((obj-car (encode-constant (car obj) constants))
2790 (obj-cdr (encode-constant (cdr obj) constants)))
2791 (asm-8 (+ #x80 (arithmetic-shift obj-car -8)))
2792 (asm-8 (bitwise-and obj-car #xff))
2793 (asm-8 (+ 0 (arithmetic-shift obj-cdr -8)))
2794 (asm-8 (bitwise-and obj-cdr #xff))))
2795 ((symbol? obj)
2796 (asm-8 #x80)
2797 (asm-8 0)
2798 (asm-8 #x20)
2799 (asm-8 0))
2800 ((string? obj)
2801 (let ((obj-enc (encode-constant (vector-ref descr 3)
2802 constants)))
2803 (asm-8 (+ #x80 (arithmetic-shift obj-enc -8)))
2804 (asm-8 (bitwise-and obj-enc #xff))
2805 (asm-8 #x40)
2806 (asm-8 0)))
2807 ((vector? obj) ;; BREGG change this, we have no ordinary vectors
2808 ;; TODO this is the OLD representation, NOT GOOD (but not used) BREGG
2809 (let ((obj-enc (encode-constant (vector-ref descr 3)
2810 constants)))
2811 (asm-8 (+ #x80 (arithmetic-shift obj-enc -8)))
2812 (asm-8 (bitwise-and obj-enc #xff))
2813 (asm-8 #x60)
2814 (asm-8 0)))
2815 ((u8vector? obj) ;; NEW, lists for now (internal representation same as ordinary vectors, who don't actually exist)
2816 (let ((obj-enc (encode-constant (vector-ref descr 3)
2817 constants))
2818 (l (length (vector-ref descr 3))))
2819 (asm-8 (+ #x80 (arithmetic-shift l -8)))
2820 (asm-8 (bitwise-and l #xff))
2821 (asm-8 (+ #x60 (arithmetic-shift obj-enc -8)))
2822 (asm-8 (bitwise-and obj-enc #xff))))
2823 (else
2824 (compiler-error "unknown object type" obj)))))
2825 constants)
2827 (let loop2 ((lst code))
2828 (if (pair? lst)
2829 (let ((instr (car lst)))
2831 (cond ((number? instr)
2832 (let ((label (cdr (assq instr labels))))
2833 (asm-label label)))
2835 ((eq? (car instr) 'entry)
2836 (let ((np (cadr instr))
2837 (rest? (caddr instr)))
2838 (asm-8 (if rest? (- np) np))))
2840 ((eq? (car instr) 'push-constant) ;; TODO FOOBAR 12 bits for constants now (actually, I don't think it matters here)
2841 (let ((n (encode-constant (cadr instr) constants)))
2842 (push-constant n)))
2844 ((eq? (car instr) 'push-stack)
2845 (push-stack (cadr instr)))
2847 ((eq? (car instr) 'push-global)
2848 (push-global (cdr (assq (cadr instr) globals))))
2850 ((eq? (car instr) 'set-global)
2851 (set-global (cdr (assq (cadr instr) globals))))
2853 ((eq? (car instr) 'call)
2854 (call (cadr instr)))
2856 ((eq? (car instr) 'jump)
2857 (jump (cadr instr)))
2859 ((eq? (car instr) 'call-toplevel)
2860 (let ((label (cdr (assq (cadr instr) labels))))
2861 (call-toplevel label)))
2863 ((eq? (car instr) 'jump-toplevel)
2864 (let ((label (cdr (assq (cadr instr) labels))))
2865 (jump-toplevel label)))
2867 ((eq? (car instr) 'goto)
2868 (let ((label (cdr (assq (cadr instr) labels))))
2869 (goto label)))
2871 ((eq? (car instr) 'goto-if-false)
2872 (let ((label (cdr (assq (cadr instr) labels))))
2873 (goto-if-false label)))
2875 ((eq? (car instr) 'closure)
2876 (let ((label (cdr (assq (cadr instr) labels))))
2877 (closure label)))
2879 ((eq? (car instr) 'prim)
2880 (case (cadr instr)
2881 ((#%number?) (prim.number?))
2882 ((#%+) (prim.+))
2883 ((#%-) (prim.-))
2884 ((#%*) (prim.*))
2885 ((#%quotient) (prim.quotient))
2886 ((#%remainder) (prim.remainder))
2887 ((#%neg) (prim.neg))
2888 ((#%=) (prim.=))
2889 ((#%<) (prim.<))
2890 ((#%ior) (prim.ior))
2891 ((#%>) (prim.>))
2892 ((#%xor) (prim.xor))
2893 ((#%pair?) (prim.pair?))
2894 ((#%cons) (prim.cons))
2895 ((#%car) (prim.car))
2896 ((#%cdr) (prim.cdr))
2897 ((#%set-car!) (prim.set-car!))
2898 ((#%set-cdr!) (prim.set-cdr!))
2899 ((#%null?) (prim.null?))
2900 ((#%eq?) (prim.eq?))
2901 ((#%not) (prim.not))
2902 ((#%get-cont) (prim.get-cont))
2903 ((#%graft-to-cont) (prim.graft-to-cont))
2904 ((#%return-to-cont) (prim.return-to-cont))
2905 ((#%halt) (prim.halt))
2906 ((#%symbol?) (prim.symbol?))
2907 ((#%string?) (prim.string?))
2908 ((#%string->list) (prim.string->list))
2909 ((#%list->string) (prim.list->string))
2910 ((#%make-u8vector) (prim.make-u8vector))
2911 ((#%u8vector-ref) (prim.u8vector-ref))
2912 ((#%u8vector-set!) (prim.u8vector-set!))
2914 ((#%print) (prim.print))
2915 ((#%clock) (prim.clock))
2916 ((#%motor) (prim.motor))
2917 ((#%led) (prim.led))
2918 ((#%led2-color) (prim.led2-color))
2919 ((#%getchar-wait ) (prim.getchar-wait))
2920 ((#%putchar) (prim.putchar))
2921 ((#%beep) (prim.beep))
2922 ((#%adc) (prim.adc))
2923 ((#%u8vector?) (prim.u8vector?)) ;; TODO was dac
2924 ((#%sernum) (prim.sernum))
2925 ((#%u8vector-length) (prim.u8vector-length))
2926 (else
2927 (compiler-error "unknown primitive" (cadr instr)))))
2929 ((eq? (car instr) 'return)
2930 (prim.return))
2932 ((eq? (car instr) 'pop)
2933 (prim.pop))
2935 ((eq? (car instr) 'shift)
2936 (prim.shift))
2938 (else
2939 (compiler-error "unknown instruction" instr)))
2941 (loop2 (cdr lst)))))
2943 (asm-assemble)
2945 (asm-write-hex-file hex-filename)
2947 (asm-end!))))))
2949 (define execute
2950 (lambda (hex-filename)
2951 '
2952 (if #f
2953 (begin
2954 (shell-command "gcc -o picobit-vm picobit-vm.c")
2955 (shell-command (string-append "./picobit-vm " hex-filename)))
2956 (shell-command (string-append "./robot . 1 " hex-filename)))))
2958 (define (sort-list l <?)
2960 (define (mergesort l)
2962 (define (merge l1 l2)
2963 (cond ((null? l1) l2)
2964 ((null? l2) l1)
2965 (else
2966 (let ((e1 (car l1)) (e2 (car l2)))
2967 (if (<? e1 e2)
2968 (cons e1 (merge (cdr l1) l2))
2969 (cons e2 (merge l1 (cdr l2))))))))
2971 (define (split l)
2972 (if (or (null? l) (null? (cdr l)))
2973 l
2974 (cons (car l) (split (cddr l)))))
2976 (if (or (null? l) (null? (cdr l)))
2977 l
2978 (let* ((l1 (mergesort (split l)))
2979 (l2 (mergesort (split (cdr l)))))
2980 (merge l1 l2))))
2982 (mergesort l))
2984 ;------------------------------------------------------------------------------
2986 (define compile
2987 (lambda (filename)
2988 (let* ((node (parse-file filename))
2989 (hex-filename
2990 (string-append
2991 (path-strip-extension filename)
2992 ".hex")))
2994 ; (pp (node->expr node))
2996 (let ((ctx (comp-none node (make-init-context))))
2997 (let ((prog (linearize (optimize-code (context-code ctx)))))
2998 ; (pp (list code: prog env: (context-env ctx)))
2999 (assemble prog hex-filename)
3000 (execute hex-filename))))))
3003 (define main
3004 (lambda (filename)
3005 (compile filename)))
3007 ;------------------------------------------------------------------------------
3009 '
3010 (define (asm-write-hex-file filename)
3011 (with-output-to-file filename
3012 (lambda ()
3014 (define (print-hex n)
3015 (display (string-ref "0123456789ABCDEF" n)))
3017 (define (print-byte n)
3018 (display ", 0x")
3019 (print-hex (quotient n 16))
3020 (print-hex (modulo n 16)))
3022 (define (print-line type addr bytes)
3023 (let ((n (length bytes))
3024 (addr-hi (quotient addr 256))
3025 (addr-lo (modulo addr 256)))
3026 ; (display ":")
3027 ; (print-byte n)
3028 ; (print-byte addr-hi)
3029 ; (print-byte addr-lo)
3030 ; (print-byte type)
3031 (for-each print-byte bytes)
3032 (let ((sum
3033 (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
3034 ; (print-byte sum)
3035 (newline))))
3037 (let loop ((lst (cdr asm-code-stream))
3038 (pos asm-start-pos)
3039 (rev-bytes '()))
3040 (if (not (null? lst))
3041 (let ((x (car lst)))
3042 (if (vector? x)
3043 (let ((kind (vector-ref x 0)))
3044 (if (not (eq? kind 'LISTING))
3045 (compiler-internal-error
3046 "asm-write-hex-file, code stream not assembled"))
3047 (loop (cdr lst)
3048 pos
3049 rev-bytes))
3050 (let ((new-pos
3051 (+ pos 1))
3052 (new-rev-bytes
3053 (cons x
3054 (if (= (modulo pos 8) 0)
3055 (begin
3056 (print-line 0
3057 (- pos (length rev-bytes))
3058 (reverse rev-bytes))
3059 '())
3060 rev-bytes))))
3061 (loop (cdr lst)
3062 new-pos
3063 new-rev-bytes))))
3064 (begin
3065 (if (not (null? rev-bytes))
3066 (print-line 0
3067 (- pos (length rev-bytes))
3068 (reverse rev-bytes)))
3069 (print-line 1 0 '())))))))