| blob | ec4660667c296be9e8f1b18628d8a09f908885b0 |
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 '#%set-fst! #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED
236 (make-var '#%set-snd! #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED
237 (make-var '#%set-trd! #t '() '() '() #f (make-primitive 2 #f #f)) ;; 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 '#%dac #t '() '() '() #f (make-primitive 1 #f #f))
249 (make-var '#%sernum #t '() '() '() #f (make-primitive 0 #f #f))
251 (make-var '#%readyq #t '() '() '() #f #f)
253 )))
255 (define env-lookup
256 (lambda (env id)
257 (let loop ((lst env) (id id))
258 (let ((b (car lst)))
259 (cond ((and (renaming? b)
260 (assq id (renaming-renamings b)))
261 =>
262 (lambda (x)
263 (loop (cdr lst) (cadr x))))
264 ((and (var? b)
265 (eq? (var-id b) id))
266 b)
267 ((null? (cdr lst))
268 (let ((x (make-var id #t '() '() '() #f #f)))
269 (set-cdr! lst (cons x '()))
270 x))
271 (else
272 (loop (cdr lst) id)))))))
274 (define env-extend
275 (lambda (env ids def)
276 (append (map (lambda (id)
277 (make-var id #f '() '() (list def) #f #f))
278 ids)
279 env)))
281 (define env-extend-renamings
282 (lambda (env renamings)
283 (cons (make-renaming renamings) env)))
285 ;-----------------------------------------------------------------------------
287 ;; Parsing.
289 (define parse-program
290 (lambda (expr env)
291 (let ((x (parse-top expr env)))
292 (cond ((null? x)
293 (parse 'value #f env))
294 ((null? (cdr x))
295 (car x))
296 (else
297 (let ((r (make-seq #f x)))
298 (for-each (lambda (y) (node-parent-set! y r)) x)
299 r))))))
301 (define parse-top
302 (lambda (expr env)
303 (cond ((and (pair? expr)
304 (eq? (car expr) 'begin))
305 (parse-top-list (cdr expr) env))
306 ((and (pair? expr)
307 (eq? (car expr) 'hide))
308 (parse-top-hide (cadr expr) (cddr expr) env))
309 ((and (pair? expr)
310 (eq? (car expr) 'rename))
311 (parse-top-rename (cadr expr) (cddr expr) env))
312 ((and (pair? expr)
313 (eq? (car expr) 'define))
314 (let ((var
315 (if (pair? (cadr expr))
316 (car (cadr expr))
317 (cadr expr)))
318 (val
319 (if (pair? (cadr expr))
320 (cons 'lambda (cons (cdr (cadr expr)) (cddr expr)))
321 (caddr expr))))
322 (let* ((var2 (env-lookup env var))
323 (val2 (parse 'value val env))
324 (r (make-def #f (list val2) var2)))
325 (node-parent-set! val2 r)
326 (var-defs-set! var2 (cons r (var-defs var2)))
327 (list r))))
328 (else
329 (list (parse 'value expr env))))))
331 (define parse-top-list
332 (lambda (lst env)
333 (if (pair? lst)
334 (append (parse-top (car lst) env)
335 (parse-top-list (cdr lst) env))
336 '())))
338 (define parse-top-hide
339 (lambda (renamings body env)
340 (append
341 (parse-top-list body
342 (env-extend-renamings env renamings))
343 #|
344 (parse-top-list
345 (map (lambda (x) (list 'define (car x) (cadr x))) renamings)
346 env)
347 |#
348 )))
350 (define parse-top-rename
351 (lambda (renamings body env)
352 (parse-top-list body
353 (env-extend-renamings env renamings))))
355 (define parse
356 (lambda (use expr env)
357 (cond ((self-eval? expr)
358 (make-cst #f '() expr))
359 ((symbol? expr)
360 (let* ((var (env-lookup env expr))
361 (r (make-ref #f '() var)))
362 (var-refs-set! var (cons r (var-refs var)))
363 r))
364 ((and (pair? expr) ;; ADDED, when we have a true macroexpander, get rid
365 (eq? (car expr) 'cond))
366 (parse use
367 `(if ,(caadr expr)
368 (begin ,@(cdadr expr))
369 ,(if (null? (cddr expr))
370 #f
371 `(cond ,@(cddr expr))))
372 env))
373 ((and (pair? expr)
374 (eq? (car expr) 'set!))
375 (let ((var (env-lookup env (cadr expr))))
376 (if (var-global? var)
377 (let* ((val (parse 'value (caddr expr) env))
378 (r (make-set #f (list val) var)))
379 (node-parent-set! val r)
380 (var-sets-set! var (cons r (var-sets var)))
381 r)
382 (compiler-error "set! is only permitted on global variables"))))
383 ((and (pair? expr)
384 (eq? (car expr) 'quote))
385 (make-cst #f '() (cadr expr)))
386 ((and (pair? expr)
387 (eq? (car expr) 'if))
388 (let* ((a (parse 'test (cadr expr) env))
389 (b (parse use (caddr expr) env))
390 (c (if (null? (cdddr expr))
391 (make-cst #f '() #f)
392 (parse use (cadddr expr) env)))
393 (r (make-if #f (list a b c))))
394 (node-parent-set! a r)
395 (node-parent-set! b r)
396 (node-parent-set! c r)
397 r))
398 ((and (pair? expr)
399 (eq? (car expr) 'lambda))
400 (let* ((pattern (cadr expr))
401 (ids (extract-ids pattern))
402 (r (make-prc #f '() #f (has-rest-param? pattern) #f))
403 (new-env (env-extend env ids r))
404 (body (parse-body (cddr expr) new-env)))
405 (prc-params-set! r (map (lambda (id) (env-lookup new-env id)) ids))
406 (node-children-set! r (list body))
407 (node-parent-set! body r)
408 r))
409 ((and (pair? expr)
410 (eq? (car expr) 'begin))
411 (let* ((exprs (map (lambda (x) (parse 'value x env)) (cdr expr)))
412 (r (make-seq #f exprs)))
413 (for-each (lambda (x) (node-parent-set! x r)) exprs)
414 r))
415 ((and (pair? expr)
416 (eq? (car expr) 'let))
417 (if (symbol? (cadr expr))
418 (compiler-error "named let is not implemented")
419 (parse use
420 (cons (cons 'lambda
421 (cons (map car (cadr expr))
422 (cddr expr)))
423 (map cadr (cadr expr)))
424 env)))
425 ((and (pair? expr)
426 (eq? (car expr) 'let*))
427 (if (null? (cadr expr))
428 (parse use
429 (cons 'let (cdr expr))
430 env)
431 (parse use
432 (list 'let
433 (list (list (caar (cadr expr))
434 (cadar (cadr expr))))
435 (cons 'let*
436 (cons (cdr (cadr expr))
437 (cddr expr))))
438 env)))
439 ((and (pair? expr)
440 (eq? (car expr) 'and))
441 (cond ((null? (cdr expr))
442 (parse use
443 #t
444 env))
445 ((null? (cddr expr))
446 (parse use
447 (cadr expr)
448 env))
449 (else
450 (parse use
451 (list 'if
452 (cadr expr)
453 (cons 'and (cddr expr))
454 #f)
455 env))))
456 ((and (pair? expr)
457 (eq? (car expr) 'or))
458 (cond ((null? (cdr expr))
459 (parse use
460 #f
461 env))
462 ((null? (cddr expr))
463 (parse use
464 (cadr expr)
465 env))
466 ((eq? use 'test)
467 (parse use
468 (list 'if
469 (cadr expr)
470 #t
471 (cons 'or (cddr expr)))
472 env))
473 (else
474 (parse use
475 (let ((v (gensym)))
476 (list 'let
477 (list (list v (cadr expr)))
478 (list 'if
479 v
480 v
481 (cons 'or (cddr expr)))))
482 env))))
483 ((and (pair? expr)
484 (memq (car expr)
485 '(quote quasiquote unquote unquote-splicing lambda if
486 set! cond and or case let let* letrec begin do define
487 delay)))
488 (compiler-error "the compiler does not implement the special form" (car expr)))
489 ((pair? expr)
490 (let* ((exprs (map (lambda (x) (parse 'value x env)) expr))
491 (r (make-call #f exprs)))
492 (for-each (lambda (x) (node-parent-set! x r)) exprs)
493 r))
494 (else
495 (compiler-error "unknown expression" expr)))))
497 (define parse-body
498 (lambda (exprs env)
499 (parse 'value (cons 'begin exprs) env)))
501 (define self-eval?
502 (lambda (expr)
503 (or (number? expr)
504 (char? expr)
505 (boolean? expr)
506 (string? expr))))
508 (define extract-ids
509 (lambda (pattern)
510 (if (pair? pattern)
511 (cons (car pattern) (extract-ids (cdr pattern)))
512 (if (symbol? pattern)
513 (cons pattern '())
514 '()))))
516 (define has-rest-param?
517 (lambda (pattern)
518 (if (pair? pattern)
519 (has-rest-param? (cdr pattern))
520 (symbol? pattern))))
522 ;-----------------------------------------------------------------------------
524 ;; Compilation context representation.
526 (define-type context
527 code
528 env
529 env2
530 )
532 (define context-change-code
533 (lambda (ctx code)
534 (make-context code
535 (context-env ctx)
536 (context-env2 ctx))))
538 (define context-change-env
539 (lambda (ctx env)
540 (make-context (context-code ctx)
541 env
542 (context-env2 ctx))))
544 (define context-change-env2
545 (lambda (ctx env2)
546 (make-context (context-code ctx)
547 (context-env ctx)
548 env2)))
550 (define make-init-context
551 (lambda ()
552 (make-context (make-init-code)
553 (make-init-env)
554 #f)))
556 (define context-make-label
557 (lambda (ctx)
558 (context-change-code ctx (code-make-label (context-code ctx)))))
560 (define context-last-label
561 (lambda (ctx)
562 (code-last-label (context-code ctx))))
564 (define context-add-bb
565 (lambda (ctx label)
566 (context-change-code ctx (code-add-bb (context-code ctx) label))))
568 (define context-add-instr
569 (lambda (ctx instr)
570 (context-change-code ctx (code-add-instr (context-code ctx) instr))))
572 ;; Representation of code.
574 (define-type code
575 last-label
576 rev-bbs
577 )
579 (define-type bb
580 label
581 rev-instrs
582 )
584 (define make-init-code
585 (lambda ()
586 (make-code 0
587 (list (make-bb 0 (list))))))
589 (define code-make-label
590 (lambda (code)
591 (let ((label (+ (code-last-label code) 1)))
592 (make-code label
593 (code-rev-bbs code)))))
595 (define code-add-bb
596 (lambda (code label)
597 (make-code
598 (code-last-label code)
599 (cons (make-bb label '())
600 (code-rev-bbs code)))))
602 (define code-add-instr
603 (lambda (code instr)
604 (let* ((rev-bbs (code-rev-bbs code))
605 (bb (car rev-bbs))
606 (rev-instrs (bb-rev-instrs bb)))
607 (make-code
608 (code-last-label code)
609 (cons (make-bb (bb-label bb)
610 (cons instr rev-instrs))
611 (cdr rev-bbs))))))
613 ;; Representation of compile-time stack.
615 (define-type stack
616 size ; number of slots
617 slots ; for each slot, the variable (or #f) contained in the slot
618 )
620 (define make-init-stack
621 (lambda ()
622 (make-stack 0 '())))
624 (define stack-extend
625 (lambda (x nb-slots stk)
626 (let ((size (stack-size stk)))
627 (make-stack
628 (+ size nb-slots)
629 (append (repeat nb-slots x) (stack-slots stk))))))
631 (define stack-discard
632 (lambda (nb-slots stk)
633 (let ((size (stack-size stk)))
634 (make-stack
635 (- size nb-slots)
636 (list-tail (stack-slots stk) nb-slots)))))
638 ;; Representation of compile-time environment.
640 (define-type env
641 local
642 closed
643 )
645 (define make-init-env
646 (lambda ()
647 (make-env (make-init-stack)
648 '())))
650 (define env-change-local
651 (lambda (env local)
652 (make-env local
653 (env-closed env))))
655 (define env-change-closed
656 (lambda (env closed)
657 (make-env (env-local env)
658 closed)))
660 (define find-local-var
661 (lambda (var env)
662 (let ((i (pos-in-list var (stack-slots (env-local env)))))
663 (or i
664 (- (+ (pos-in-list var (env-closed env)) 1))))))
666 (define prc->env
667 (lambda (prc)
668 (make-env
669 (let ((params (prc-params prc)))
670 (make-stack (length params)
671 (append (map var-id params) '())))
672 (let ((vars (varset->list (non-global-fv prc))))
673 ; (pp (map var-id vars))
674 (map var-id vars)))))
676 ;-----------------------------------------------------------------------------
678 (define gen-instruction
679 (lambda (instr nb-pop nb-push ctx)
680 (let* ((env
681 (context-env ctx))
682 (stk
683 (stack-extend #f
684 nb-push
685 (stack-discard nb-pop
686 (env-local env)))))
687 (context-add-instr (context-change-env ctx (env-change-local env stk))
688 instr))))
690 (define gen-entry
691 (lambda (nparams rest? ctx)
692 (gen-instruction (list 'entry nparams rest?) 0 0 ctx)))
694 (define gen-push-constant
695 (lambda (val ctx)
696 (gen-instruction (list 'push-constant val) 0 1 ctx)))
698 (define gen-push-unspecified
699 (lambda (ctx)
700 (gen-push-constant #f ctx)))
702 (define gen-push-local-var
703 (lambda (var ctx)
704 ; (pp (list var: var local: (stack-slots (env-local (context-env ctx))) (env-closed (context-env ctx))))
705 (let ((i (find-local-var var (context-env ctx))))
706 (if (>= i 0)
707 (gen-push-stack i ctx)
708 (gen-push-stack
709 (+ 1 ;; TODO the +1 was added because closures are not really pairs anymore, they only have a cdr
710 (- -1 i)
711 (length (stack-slots (env-local (context-env ctx))))) ctx)))))
713 (define gen-push-stack
714 (lambda (pos ctx)
715 (gen-instruction (list 'push-stack pos) 0 1 ctx)))
717 (define gen-push-global
718 (lambda (var ctx)
719 (gen-instruction (list 'push-global var) 0 1 ctx)))
721 (define gen-set-global
722 (lambda (var ctx)
723 (gen-instruction (list 'set-global var) 1 0 ctx)))
725 (define gen-call
726 (lambda (nargs ctx)
727 (gen-instruction (list 'call nargs) (+ nargs 1) 1 ctx)))
729 (define gen-jump
730 (lambda (nargs ctx)
731 (gen-instruction (list 'jump nargs) (+ nargs 1) 1 ctx)))
733 (define gen-call-toplevel
734 (lambda (nargs id ctx)
735 (gen-instruction (list 'call-toplevel id) nargs 1 ctx)))
737 (define gen-jump-toplevel
738 (lambda (nargs id ctx)
739 (gen-instruction (list 'jump-toplevel id) nargs 1 ctx)))
741 (define gen-goto
742 (lambda (label ctx)
743 (gen-instruction (list 'goto label) 0 0 ctx)))
745 (define gen-goto-if-false
746 (lambda (label-false label-true ctx)
747 (gen-instruction (list 'goto-if-false label-false label-true) 1 0 ctx)))
749 (define gen-closure
750 (lambda (label-entry ctx)
751 (gen-instruction (list 'closure label-entry) 1 1 ctx))) ;; TODO was 2 1
753 (define gen-prim
754 (lambda (id nargs unspec-result? ctx)
755 (gen-instruction
756 (list 'prim id)
757 nargs
758 (if unspec-result? 0 1)
759 ctx)))
761 (define gen-shift
762 (lambda (n ctx)
763 (if (> n 0)
764 (gen-instruction (list 'shift) 1 0 (gen-shift (- n 1) ctx))
765 ctx)))
767 (define gen-pop
768 (lambda (ctx)
769 (gen-instruction (list 'pop) 1 0 ctx)))
771 (define gen-return
772 (lambda (ctx)
773 (let ((ss (stack-size (env-local (context-env ctx)))))
774 (gen-instruction (list 'return) ss 0 ctx))))
776 ;-----------------------------------------------------------------------------
778 (define child1
779 (lambda (node)
780 (car (node-children node))))
782 (define child2
783 (lambda (node)
784 (cadr (node-children node))))
786 (define child3
787 (lambda (node)
788 (caddr (node-children node))))
790 (define comp-none
791 (lambda (node ctx)
793 (cond ((or (cst? node)
794 (ref? node)
795 (prc? node))
796 ctx)
798 ((def? node)
799 (let ((var (def-var node)))
800 (if (toplevel-prc-with-non-rest-correct-calls? var)
801 (comp-prc (child1 node) #f ctx)
802 (if (var-needed? var)
803 (let ((ctx2 (comp-push (child1 node) ctx)))
804 (gen-set-global (var-id var) ctx2))
805 (comp-none (child1 node) ctx)))))
807 ((set? node)
808 (let ((var (set-var node)))
809 (if (var-needed? var)
810 (let ((ctx2 (comp-push (child1 node) ctx)))
811 (gen-set-global (var-id var) ctx2))
812 (comp-none (child1 node) ctx))))
814 ((if? node)
815 (let* ((ctx2
816 (context-make-label ctx))
817 (label-then
818 (context-last-label ctx2))
819 (ctx3
820 (context-make-label ctx2))
821 (label-else
822 (context-last-label ctx3))
823 (ctx4
824 (context-make-label ctx3))
825 (label-then-join
826 (context-last-label ctx4))
827 (ctx5
828 (context-make-label ctx4))
829 (label-else-join
830 (context-last-label ctx5))
831 (ctx6
832 (context-make-label ctx5))
833 (label-join
834 (context-last-label ctx6))
835 (ctx7
836 (comp-test (child1 node) label-then label-else ctx6))
837 (ctx8
838 (gen-goto
839 label-else-join
840 (comp-none (child3 node)
841 (context-change-env2
842 (context-add-bb ctx7 label-else)
843 #f))))
844 (ctx9
845 (gen-goto
846 label-then-join
847 (comp-none (child2 node)
848 (context-change-env
849 (context-add-bb ctx8 label-then)
850 (context-env2 ctx7)))))
851 (ctx10
852 (gen-goto
853 label-join
854 (context-add-bb ctx9 label-else-join)))
855 (ctx11
856 (gen-goto
857 label-join
858 (context-add-bb ctx10 label-then-join)))
859 (ctx12
860 (context-add-bb ctx11 label-join)))
861 ctx12))
863 ((call? node)
864 (comp-call node 'none ctx))
866 ((seq? node)
867 (let ((children (node-children node)))
868 (if (null? children)
869 ctx
870 (let loop ((lst children)
871 (ctx ctx))
872 (if (null? (cdr lst))
873 (comp-none (car lst) ctx)
874 (loop (cdr lst)
875 (comp-none (car lst) ctx)))))))
877 (else
878 (compiler-error "unknown expression type" node)))))
880 (define comp-tail
881 (lambda (node ctx)
883 (cond ((or (cst? node)
884 (ref? node)
885 (def? node)
886 (set? node)
887 (prc? node)
888 ; (call? node)
889 )
890 (gen-return (comp-push node ctx)))
892 ((if? node)
893 (let* ((ctx2
894 (context-make-label ctx))
895 (label-then
896 (context-last-label ctx2))
897 (ctx3
898 (context-make-label ctx2))
899 (label-else
900 (context-last-label ctx3))
901 (ctx4
902 (comp-test (child1 node) label-then label-else ctx3))
903 (ctx5
904 (comp-tail (child3 node)
905 (context-change-env2
906 (context-add-bb ctx4 label-else)
907 #f)))
908 (ctx6
909 (comp-tail (child2 node)
910 (context-change-env
911 (context-add-bb ctx5 label-then)
912 (context-env2 ctx4)))))
913 ctx6))
915 ((call? node)
916 (comp-call node 'tail ctx))
918 ((seq? node)
919 (let ((children (node-children node)))
920 (if (null? children)
921 (gen-return (gen-push-unspecified ctx))
922 (let loop ((lst children)
923 (ctx ctx))
924 (if (null? (cdr lst))
925 (comp-tail (car lst) ctx)
926 (loop (cdr lst)
927 (comp-none (car lst) ctx)))))))
929 (else
930 (compiler-error "unknown expression type" node)))))
932 (define comp-push
933 (lambda (node ctx)
935 '(
936 (display "--------------\n")
937 (pp (node->expr node))
938 (pp env)
939 (pp stk)
940 )
942 (cond ((cst? node)
943 (let ((val (cst-val node)))
944 (gen-push-constant val ctx)))
946 ((ref? node)
947 (let ((var (ref-var node)))
948 (if (var-global? var)
949 (if (null? (var-defs var))
950 (compiler-error "undefined variable:" (var-id var))
951 (let ((val (child1 (car (var-defs var)))))
952 (if (and (not (mutable-var? var))
953 (cst? val))
954 (begin (pp (var-id var))
955 ;; TODO BARF had no effect, literals are
956 ;; still the only constants
957 (gen-push-constant (cst-val val) ctx))
958 (gen-push-global (var-id var) ctx))))
959 ;; TODO I though this might have caused problems, but the programs failed the same way at the same place with and without this
960 (gen-push-local-var (var-id var) ctx))))
962 ((or (def? node)
963 (set? node))
964 (gen-push-unspecified (comp-none 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-push (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-push (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 ((prc? node)
1016 (comp-prc node #t ctx))
1018 ((call? node)
1019 (comp-call node 'push ctx))
1021 ((seq? node)
1022 (let ((children (node-children node)))
1023 (if (null? children)
1024 (gen-push-unspecified ctx)
1025 (let loop ((lst children)
1026 (ctx ctx))
1027 (if (null? (cdr lst))
1028 (comp-push (car lst) ctx)
1029 (loop (cdr lst)
1030 (comp-none (car lst) ctx)))))))
1032 (else
1033 (compiler-error "unknown expression type" node)))))
1035 (define (build-closure label-entry vars ctx)
1037 (define (build vars ctx)
1038 (if (null? vars)
1039 (gen-push-constant '() ctx)
1040 (gen-prim '#%cons
1041 2
1042 #f
1043 (build (cdr vars)
1044 (gen-push-local-var (car vars) ctx)))))
1046 (if (null? vars)
1047 (gen-closure label-entry ;; TODO it seems no actual closure objects are stored in ROM, only the code to generate them, so we probably are ok if we don't modify anything, the vm takes care of everything
1048 (gen-push-constant '() ctx)) ;; TODO was (gen-push-constant #f ctx)
1049 (gen-closure label-entry
1050 (build vars ctx)))) ;; TODO was (gen-push-constant #f ctx)
1051 ;; 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
1053 (define comp-prc
1054 (lambda (node closure? ctx)
1055 (let* ((ctx2
1056 (context-make-label ctx))
1057 (label-entry
1058 (context-last-label ctx2))
1059 (ctx3
1060 (context-make-label ctx2))
1061 (label-continue
1062 (context-last-label ctx3))
1063 (body-env
1064 (prc->env node))
1065 (ctx4
1066 (if closure?
1067 (build-closure label-entry (env-closed body-env) ctx3)
1068 ctx3))
1069 (ctx5
1070 (gen-goto label-continue ctx4))
1071 (ctx6
1072 (gen-entry (length (prc-params node))
1073 (prc-rest? node)
1074 (context-add-bb (context-change-env ctx5
1075 body-env)
1076 label-entry)))
1077 (ctx7
1078 (comp-tail (child1 node) ctx6)))
1079 (prc-entry-label-set! node label-entry)
1080 (context-add-bb (context-change-env ctx7 (context-env ctx5))
1081 label-continue))))
1083 (define comp-call
1084 (lambda (node reason ctx)
1085 (let* ((op (child1 node))
1086 (args (cdr (node-children node)))
1087 (nargs (length args)))
1088 (let loop ((lst args)
1089 (ctx ctx))
1090 (if (pair? lst)
1092 (let ((arg (car lst)))
1093 (loop (cdr lst)
1094 (comp-push arg ctx)))
1096 (cond ((and (ref? op)
1097 (var-primitive (ref-var op)))
1098 (let* ((var (ref-var op))
1099 (id (var-id var))
1100 (primitive (var-primitive var))
1101 (prim-nargs (primitive-nargs primitive)))
1103 (define use-result
1104 (lambda (ctx2)
1105 (cond ((eq? reason 'tail)
1106 (gen-return
1107 (if (primitive-unspecified-result? primitive)
1108 (gen-push-unspecified ctx2)
1109 ctx2)))
1110 ((eq? reason 'push)
1111 (if (primitive-unspecified-result? primitive)
1112 (gen-push-unspecified ctx2)
1113 ctx2))
1114 (else
1115 (if (primitive-unspecified-result? primitive)
1116 ctx2
1117 (gen-pop ctx2))))))
1119 (use-result
1120 (if (primitive-inliner primitive)
1121 ((primitive-inliner primitive) ctx)
1122 (if (not (= nargs prim-nargs))
1123 (compiler-error "primitive called with wrong number of arguments" id)
1124 (gen-prim
1125 id
1126 prim-nargs
1127 (primitive-unspecified-result? primitive)
1128 ctx))))))
1131 ((and (ref? op)
1132 (toplevel-prc-with-non-rest-correct-calls? (ref-var op)))
1133 =>
1134 (lambda (prc)
1135 (cond ((eq? reason 'tail)
1136 (gen-jump-toplevel nargs prc ctx))
1137 ((eq? reason 'push)
1138 (gen-call-toplevel nargs prc ctx))
1139 (else
1140 (gen-pop (gen-call-toplevel nargs prc ctx))))))
1142 (else
1143 (let ((ctx2 (comp-push op ctx)))
1144 (cond ((eq? reason 'tail)
1145 (gen-jump nargs ctx2))
1146 ((eq? reason 'push)
1147 (gen-call nargs ctx2))
1148 (else
1149 (gen-pop (gen-call nargs ctx2))))))))))))
1151 (define comp-test
1152 (lambda (node label-true label-false ctx)
1153 (cond ((cst? node)
1154 (let ((ctx2
1155 (gen-goto
1156 (let ((val (cst-val node)))
1157 (if val
1158 label-true
1159 label-false))
1160 ctx)))
1161 (context-change-env2 ctx2 (context-env ctx2))))
1163 ((or (ref? node)
1164 (def? node)
1165 (set? node)
1166 (if? node)
1167 (call? node)
1168 (seq? node))
1169 (let* ((ctx2
1170 (comp-push node ctx))
1171 (ctx3
1172 (gen-goto-if-false label-false label-true ctx2)))
1173 (context-change-env2 ctx3 (context-env ctx3))))
1175 ((prc? node)
1176 (let ((ctx2
1177 (gen-goto label-true ctx)))
1178 (context-change-env2 ctx2 (context-env ctx2))))
1180 (else
1181 (compiler-error "unknown expression type" node)))))
1183 ;-----------------------------------------------------------------------------
1185 (define toplevel-prc?
1186 (lambda (var)
1187 (and (not (mutable-var? var))
1188 (let ((d (var-defs var)))
1189 (and (pair? d)
1190 (null? (cdr d))
1191 (let ((val (child1 (car d))))
1192 (and (prc? val)
1193 val)))))))
1195 (define toplevel-prc-with-non-rest-correct-calls?
1196 (lambda (var)
1197 (let ((prc (toplevel-prc? var)))
1198 (and prc
1199 (not (prc-rest? prc))
1200 (every (lambda (r)
1201 (let ((parent (node-parent r)))
1202 (and (call? parent)
1203 (eq? (child1 parent) r)
1204 (= (length (prc-params prc))
1205 (- (length (node-children parent)) 1)))))
1206 (var-refs var))
1207 prc))))
1209 (define mutable-var? ;; TODO use it to put immutable globals in rom
1210 (lambda (var)
1211 (not (null? (var-sets var)))))
1213 (define global-fv
1214 (lambda (node)
1215 (list->varset
1216 (keep var-global?
1217 (varset->list (fv node))))))
1219 (define non-global-fv
1220 (lambda (node)
1221 (list->varset
1222 (keep (lambda (x) (not (var-global? x)))
1223 (varset->list (fv node))))))
1225 (define fv
1226 (lambda (node)
1227 (cond ((cst? node)
1228 (varset-empty))
1229 ((ref? node)
1230 (let ((var (ref-var node)))
1231 (varset-singleton var)))
1232 ((def? node)
1233 (let ((var (def-var node))
1234 (val (child1 node)))
1235 (varset-union
1236 (varset-singleton var)
1237 (fv val))))
1238 ((set? node)
1239 (let ((var (set-var node))
1240 (val (child1 node)))
1241 (varset-union
1242 (varset-singleton var)
1243 (fv val))))
1244 ((if? node)
1245 (let ((a (list-ref (node-children node) 0))
1246 (b (list-ref (node-children node) 1))
1247 (c (list-ref (node-children node) 2)))
1248 (varset-union-multi (list (fv a) (fv b) (fv c)))))
1249 ((prc? node)
1250 (let ((body (list-ref (node-children node) 0)))
1251 (varset-difference
1252 (fv body)
1253 (build-params-varset (prc-params node)))))
1254 ((call? node)
1255 (varset-union-multi (map fv (node-children node))))
1256 ((seq? node)
1257 (varset-union-multi (map fv (node-children node))))
1258 (else
1259 (compiler-error "unknown expression type" node)))))
1261 (define build-params-varset
1262 (lambda (params)
1263 (list->varset params)))
1265 (define mark-needed-global-vars!
1266 (lambda (global-env node)
1268 (define readyq
1269 (env-lookup global-env '#%readyq))
1271 (define mark-var!
1272 (lambda (var)
1273 (if (and (var-global? var)
1274 (not (var-needed? var)))
1275 (begin
1276 (var-needed?-set! var #t)
1277 (for-each
1278 (lambda (def)
1279 (let ((val (child1 def)))
1280 (if (side-effect-less? val)
1281 (mark! val))))
1282 (var-defs var))
1283 (if (eq? var readyq)
1284 (begin
1285 (mark-var!
1286 (env-lookup global-env '#%start-first-process))
1287 (mark-var!
1288 (env-lookup global-env '#%exit))))))))
1290 (define side-effect-less?
1291 (lambda (node)
1292 (or (cst? node)
1293 (ref? node)
1294 (prc? node))))
1296 (define mark!
1297 (lambda (node)
1298 (cond ((cst? node))
1299 ((ref? node)
1300 (let ((var (ref-var node)))
1301 (mark-var! var)))
1302 ((def? node)
1303 (let ((var (def-var node))
1304 (val (child1 node)))
1305 (if (not (side-effect-less? val))
1306 (mark! val))))
1307 ((set? node)
1308 (let ((var (set-var node))
1309 (val (child1 node)))
1310 (mark! val)))
1311 ((if? node)
1312 (let ((a (list-ref (node-children node) 0))
1313 (b (list-ref (node-children node) 1))
1314 (c (list-ref (node-children node) 2)))
1315 (mark! a)
1316 (mark! b)
1317 (mark! c)))
1318 ((prc? node)
1319 (let ((body (list-ref (node-children node) 0)))
1320 (mark! body)))
1321 ((call? node)
1322 (for-each mark! (node-children node)))
1323 ((seq? node)
1324 (for-each mark! (node-children node)))
1325 (else
1326 (compiler-error "unknown expression type" node)))))
1328 (mark! node)
1329 ))
1331 ;-----------------------------------------------------------------------------
1333 ;; Variable sets
1335 (define (varset-empty) ; return the empty set
1336 '())
1338 (define (varset-singleton x) ; create a set containing only 'x'
1339 (list x))
1341 (define (list->varset lst) ; convert list to set
1342 lst)
1344 (define (varset->list set) ; convert set to list
1345 set)
1347 (define (varset-size set) ; return cardinality of set
1348 (list-length set))
1350 (define (varset-empty? set) ; is 'x' the empty set?
1351 (null? set))
1353 (define (varset-member? x set) ; is 'x' a member of the 'set'?
1354 (and (not (null? set))
1355 (or (eq? x (car set))
1356 (varset-member? x (cdr set)))))
1358 (define (varset-adjoin set x) ; add the element 'x' to the 'set'
1359 (if (varset-member? x set) set (cons x set)))
1361 (define (varset-remove set x) ; remove the element 'x' from 'set'
1362 (cond ((null? set)
1363 '())
1364 ((eq? (car set) x)
1365 (cdr set))
1366 (else
1367 (cons (car set) (varset-remove (cdr set) x)))))
1369 (define (varset-equal? s1 s2) ; are 's1' and 's2' equal sets?
1370 (and (varset-subset? s1 s2)
1371 (varset-subset? s2 s1)))
1373 (define (varset-subset? s1 s2) ; is 's1' a subset of 's2'?
1374 (cond ((null? s1)
1375 #t)
1376 ((varset-member? (car s1) s2)
1377 (varset-subset? (cdr s1) s2))
1378 (else
1379 #f)))
1381 (define (varset-difference set1 set2) ; return difference of sets
1382 (cond ((null? set1)
1383 '())
1384 ((varset-member? (car set1) set2)
1385 (varset-difference (cdr set1) set2))
1386 (else
1387 (cons (car set1) (varset-difference (cdr set1) set2)))))
1389 (define (varset-union set1 set2) ; return union of sets
1390 (define (union s1 s2)
1391 (cond ((null? s1)
1392 s2)
1393 ((varset-member? (car s1) s2)
1394 (union (cdr s1) s2))
1395 (else
1396 (cons (car s1) (union (cdr s1) s2)))))
1397 (if (varset-smaller? set1 set2)
1398 (union set1 set2)
1399 (union set2 set1)))
1401 (define (varset-intersection set1 set2) ; return intersection of sets
1402 (define (intersection s1 s2)
1403 (cond ((null? s1)
1404 '())
1405 ((varset-member? (car s1) s2)
1406 (cons (car s1) (intersection (cdr s1) s2)))
1407 (else
1408 (intersection (cdr s1) s2))))
1409 (if (varset-smaller? set1 set2)
1410 (intersection set1 set2)
1411 (intersection set2 set1)))
1413 (define (varset-intersects? set1 set2) ; do sets 'set1' and 'set2' intersect?
1414 (not (varset-empty? (varset-intersection set1 set2))))
1416 (define (varset-smaller? set1 set2)
1417 (if (null? set1)
1418 (not (null? set2))
1419 (if (null? set2)
1420 #f
1421 (varset-smaller? (cdr set1) (cdr set2)))))
1423 (define (varset-union-multi sets)
1424 (if (null? sets)
1425 (varset-empty)
1426 (n-ary varset-union (car sets) (cdr sets))))
1428 (define (n-ary function first rest)
1429 (if (null? rest)
1430 first
1431 (n-ary function (function first (car rest)) (cdr rest))))
1433 ;------------------------------------------------------------------------------
1435 (define code->vector
1436 (lambda (code)
1437 (let ((v (make-vector (+ (code-last-label code) 1))))
1438 (for-each
1439 (lambda (bb)
1440 (vector-set! v (bb-label bb) bb))
1441 (code-rev-bbs code))
1442 v)))
1444 (define bbs->ref-counts
1445 (lambda (bbs)
1446 (let ((ref-counts (make-vector (vector-length bbs) 0)))
1448 (define visit
1449 (lambda (label)
1450 (let ((ref-count (vector-ref ref-counts label)))
1451 (vector-set! ref-counts label (+ ref-count 1))
1452 (if (= ref-count 0)
1453 (let* ((bb (vector-ref bbs label))
1454 (rev-instrs (bb-rev-instrs bb)))
1455 (for-each
1456 (lambda (instr)
1457 (let ((opcode (car instr)))
1458 (cond ((eq? opcode 'goto)
1459 (visit (cadr instr)))
1460 ((eq? opcode 'goto-if-false)
1461 (visit (cadr instr))
1462 (visit (caddr instr)))
1463 ((or (eq? opcode 'closure)
1464 (eq? opcode 'call-toplevel)
1465 (eq? opcode 'jump-toplevel))
1466 (visit (cadr instr))))))
1467 rev-instrs))))))
1469 (visit 0)
1471 ref-counts)))
1473 (define resolve-toplevel-labels!
1474 (lambda (bbs)
1475 (let loop ((i 0))
1476 (if (< i (vector-length bbs))
1477 (let* ((bb (vector-ref bbs i))
1478 (rev-instrs (bb-rev-instrs bb)))
1479 (bb-rev-instrs-set!
1480 bb
1481 (map (lambda (instr)
1482 (let ((opcode (car instr)))
1483 (cond ((eq? opcode 'call-toplevel)
1484 (list opcode
1485 (prc-entry-label (cadr instr))))
1486 ((eq? opcode 'jump-toplevel)
1487 (list opcode
1488 (prc-entry-label (cadr instr))))
1489 (else
1490 instr))))
1491 rev-instrs))
1492 (loop (+ i 1)))))))
1494 (define tighten-jump-cascades!
1495 (lambda (bbs)
1496 (let ((ref-counts (bbs->ref-counts bbs)))
1498 (define resolve
1499 (lambda (label)
1500 (let* ((bb (vector-ref bbs label))
1501 (rev-instrs (bb-rev-instrs bb)))
1502 (and (or (null? (cdr rev-instrs))
1503 (= (vector-ref ref-counts label) 1))
1504 rev-instrs))))
1506 (let loop1 ()
1507 (let loop2 ((i 0)
1508 (changed? #f))
1509 (if (< i (vector-length bbs))
1510 (if (> (vector-ref ref-counts i) 0)
1511 (let* ((bb (vector-ref bbs i))
1512 (rev-instrs (bb-rev-instrs bb))
1513 (jump (car rev-instrs))
1514 (opcode (car jump)))
1515 (cond ((eq? opcode 'goto) ;; BREGG search for goto paused here
1516 (let* ((label (cadr jump))
1517 (jump-replacement (resolve label)))
1518 (if jump-replacement
1519 (begin
1520 (vector-set!
1521 bbs
1522 i
1523 (make-bb (bb-label bb)
1524 (append jump-replacement
1525 (cdr rev-instrs))))
1526 (loop2 (+ i 1)
1527 #t))
1528 (loop2 (+ i 1)
1529 changed?))))
1530 ((eq? opcode 'goto-if-false)
1531 (let* ((label-then (cadr jump))
1532 (label-else (caddr jump))
1533 (jump-then-replacement (resolve label-then))
1534 (jump-else-replacement (resolve label-else)))
1535 (if (and jump-then-replacement
1536 (null? (cdr jump-then-replacement))
1537 jump-else-replacement
1538 (null? (cdr jump-else-replacement))
1539 (or (eq? (caar jump-then-replacement) 'goto)
1540 (eq? (caar jump-else-replacement) 'goto)))
1541 (begin
1542 (vector-set!
1543 bbs
1544 i
1545 (make-bb (bb-label bb)
1546 (cons (list 'goto-if-false
1547 (if (eq? (caar jump-then-replacement) 'goto)
1548 (cadar jump-then-replacement)
1549 label-then)
1550 (if (eq? (caar jump-else-replacement) 'goto)
1551 (cadar jump-else-replacement)
1552 label-else))
1553 (cdr rev-instrs))))
1554 (loop2 (+ i 1)
1555 #t))
1556 (loop2 (+ i 1)
1557 changed?))))
1558 (else
1559 (loop2 (+ i 1)
1560 changed?))))
1561 (loop2 (+ i 1)
1562 changed?))
1563 (if changed?
1564 (loop1))))))))
1566 (define remove-useless-bbs!
1567 (lambda (bbs)
1568 (let ((ref-counts (bbs->ref-counts bbs)))
1569 (let loop1 ((label 0) (new-label 0))
1570 (if (< label (vector-length bbs))
1571 (if (> (vector-ref ref-counts label) 0)
1572 (let ((bb (vector-ref bbs label)))
1573 (vector-set!
1574 bbs
1575 label
1576 (make-bb new-label (bb-rev-instrs bb)))
1577 (loop1 (+ label 1) (+ new-label 1)))
1578 (loop1 (+ label 1) new-label))
1579 (renumber-labels bbs ref-counts new-label))))))
1581 (define renumber-labels
1582 (lambda (bbs ref-counts n)
1583 (let ((new-bbs (make-vector n)))
1584 (let loop2 ((label 0))
1585 (if (< label (vector-length bbs))
1586 (if (> (vector-ref ref-counts label) 0)
1587 (let* ((bb (vector-ref bbs label))
1588 (new-label (bb-label bb))
1589 (rev-instrs (bb-rev-instrs bb)))
1591 (define fix
1592 (lambda (instr)
1594 (define new-label
1595 (lambda (label)
1596 (bb-label (vector-ref bbs label))))
1598 (let ((opcode (car instr)))
1599 (cond ((eq? opcode 'closure)
1600 (list 'closure
1601 (new-label (cadr instr))))
1602 ((eq? opcode 'call-toplevel)
1603 (list 'call-toplevel
1604 (new-label (cadr instr))))
1605 ((eq? opcode 'jump-toplevel)
1606 (list 'jump-toplevel
1607 (new-label (cadr instr))))
1608 ((eq? opcode 'goto)
1609 (list 'goto
1610 (new-label (cadr instr))))
1611 ((eq? opcode 'goto-if-false)
1612 (list 'goto-if-false
1613 (new-label (cadr instr))
1614 (new-label (caddr instr))))
1615 (else
1616 instr)))))
1618 (vector-set!
1619 new-bbs
1620 new-label
1621 (make-bb new-label (map fix rev-instrs)))
1622 (loop2 (+ label 1)))
1623 (loop2 (+ label 1)))
1624 new-bbs)))))
1626 (define reorder!
1627 (lambda (bbs)
1628 (let* ((done (make-vector (vector-length bbs) #f)))
1630 (define unscheduled?
1631 (lambda (label)
1632 (not (vector-ref done label))))
1634 (define label-refs
1635 (lambda (instrs todo)
1636 (if (pair? instrs)
1637 (let* ((instr (car instrs))
1638 (opcode (car instr)))
1639 (cond ((or (eq? opcode 'closure)
1640 (eq? opcode 'call-toplevel)
1641 (eq? opcode 'jump-toplevel))
1642 (label-refs (cdr instrs) (cons (cadr instr) todo)))
1643 (else
1644 (label-refs (cdr instrs) todo))))
1645 todo)))
1647 (define schedule-here
1648 (lambda (label new-label todo cont)
1649 (let* ((bb (vector-ref bbs label))
1650 (rev-instrs (bb-rev-instrs bb))
1651 (jump (car rev-instrs))
1652 (opcode (car jump))
1653 (new-todo (label-refs rev-instrs todo)))
1654 (vector-set! bbs label (make-bb new-label rev-instrs))
1655 (vector-set! done label #t)
1656 (cond ((eq? opcode 'goto)
1657 (let ((label (cadr jump)))
1658 (if (unscheduled? label)
1659 (schedule-here label
1660 (+ new-label 1)
1661 new-todo
1662 cont)
1663 (cont (+ new-label 1)
1664 new-todo))))
1665 ((eq? opcode 'goto-if-false)
1666 (let ((label-then (cadr jump))
1667 (label-else (caddr jump)))
1668 (cond ((unscheduled? label-else)
1669 (schedule-here label-else
1670 (+ new-label 1)
1671 (cons label-then new-todo)
1672 cont))
1673 ((unscheduled? label-then)
1674 (schedule-here label-then
1675 (+ new-label 1)
1676 new-todo
1677 cont))
1678 (else
1679 (cont (+ new-label 1)
1680 new-todo)))))
1681 (else
1682 (cont (+ new-label 1)
1683 new-todo))))))
1685 (define schedule-somewhere
1686 (lambda (label new-label todo cont)
1687 (schedule-here label new-label todo cont)))
1689 (define schedule-todo
1690 (lambda (new-label todo)
1691 (if (pair? todo)
1692 (let ((label (car todo)))
1693 (if (unscheduled? label)
1694 (schedule-somewhere label
1695 new-label
1696 (cdr todo)
1697 schedule-todo)
1698 (schedule-todo new-label
1699 (cdr todo)))))))
1702 (schedule-here 0 0 '() schedule-todo)
1704 (renumber-labels bbs
1705 (make-vector (vector-length bbs) 1)
1706 (vector-length bbs)))))
1708 (define linearize
1709 (lambda (bbs)
1710 (let loop ((label (- (vector-length bbs) 1))
1711 (lst '()))
1712 (if (>= label 0)
1713 (let* ((bb (vector-ref bbs label))
1714 (rev-instrs (bb-rev-instrs bb))
1715 (jump (car rev-instrs))
1716 (opcode (car jump)))
1717 (loop (- label 1)
1718 (append
1719 (list label)
1720 (reverse
1721 (cond ((eq? opcode 'goto)
1722 (if (= (cadr jump) (+ label 1))
1723 (cdr rev-instrs)
1724 rev-instrs))
1725 ((eq? opcode 'goto-if-false)
1726 (cond ((= (caddr jump) (+ label 1))
1727 (cons (list 'goto-if-false (cadr jump))
1728 (cdr rev-instrs)))
1729 ((= (cadr jump) (+ label 1))
1730 (cons (list 'goto-if-not-false (caddr jump))
1731 (cdr rev-instrs)))
1732 (else
1733 (cons (list 'goto (caddr jump))
1734 (cons (list 'goto-if-false (cadr jump))
1735 (cdr rev-instrs))))))
1736 (else
1737 rev-instrs)))
1738 lst)))
1739 lst))))
1741 (define optimize-code
1742 (lambda (code)
1743 (let ((bbs (code->vector code)))
1744 (resolve-toplevel-labels! bbs)
1745 (tighten-jump-cascades! bbs)
1746 (let ((bbs (remove-useless-bbs! bbs)))
1747 (reorder! bbs)))))
1750 (define expand-loads ;; ADDED
1751 (lambda (exprs)
1752 (map (lambda (e)
1753 (if (eq? (car e) 'load)
1754 (cons 'begin
1755 (expand-loads (with-input-from-file (cadr e) read-all)))
1756 e))
1757 exprs)))
1759 (define parse-file
1760 (lambda (filename)
1761 (let* ((library
1762 (with-input-from-file "library.scm" read-all))
1763 (toplevel-exprs
1764 (expand-loads (append library ;; ADDED (didn't have expand-loads)
1765 (with-input-from-file filename read-all))))
1766 (global-env
1767 (make-global-env))
1768 (parsed-prog
1769 (parse-top (cons 'begin toplevel-exprs) global-env)))
1771 (for-each
1772 (lambda (node)
1773 (mark-needed-global-vars! global-env node))
1774 parsed-prog)
1776 (extract-parts
1777 parsed-prog
1778 (lambda (defs after-defs)
1780 (define make-seq-preparsed
1781 (lambda (exprs)
1782 (let ((r (make-seq #f exprs)))
1783 (for-each (lambda (x) (node-parent-set! x r)) exprs)
1784 r)))
1786 (define make-call-preparsed
1787 (lambda (exprs)
1788 (let ((r (make-call #f exprs)))
1789 (for-each (lambda (x) (node-parent-set! x r)) exprs)
1790 r)))
1792 (if (var-needed?
1793 (env-lookup global-env '#%readyq))
1794 (make-seq-preparsed
1795 (list (make-seq-preparsed defs)
1796 (make-call-preparsed
1797 (list (parse 'value '#%start-first-process global-env)
1798 (let* ((pattern
1799 '())
1800 (ids
1801 (extract-ids pattern))
1802 (r
1803 (make-prc #f '() #f (has-rest-param? pattern) #f))
1804 (new-env
1805 (env-extend global-env ids r))
1806 (body
1807 (make-seq-preparsed after-defs)))
1808 (prc-params-set!
1809 r
1810 (map (lambda (id) (env-lookup new-env id))
1811 ids))
1812 (node-children-set! r (list body))
1813 (node-parent-set! body r)
1814 r)))
1815 (parse 'value
1816 '(#%exit)
1817 global-env)))
1818 (make-seq-preparsed
1819 (append defs
1820 after-defs
1821 (list (parse 'value
1822 '(#%halt)
1823 global-env))))))))))
1825 (define extract-parts
1826 (lambda (lst cont)
1827 (if (or (null? lst)
1828 (not (def? (car lst))))
1829 (cont '() lst)
1830 (extract-parts
1831 (cdr lst)
1832 (lambda (d ad)
1833 (cont (cons (car lst) d) ad))))))
1835 ;------------------------------------------------------------------------------
1837 ;;(include "asm.scm")
1839 ;;; File: "asm.scm"
1840 ;;;
1841 ;;; This module implements the generic assembler.
1843 ;;(##declare (standard-bindings) (fixnum) (block))
1845 (define compiler-internal-error error)
1847 ;; (asm-begin! start-pos big-endian?) initializes the assembler and
1848 ;; starts a new empty code stream at address "start-pos". It must be
1849 ;; called every time a new code stream is to be built. The argument
1850 ;; "big-endian?" indicates the byte ordering to use for 16, 32 and 64
1851 ;; bit values. After a call to "asm-begin!" the code stream is built
1852 ;; by calling the following procedures:
1853 ;;
1854 ;; asm-8 to add an 8 bit integer to the code stream
1855 ;; asm-16 to add a 16 bit integer to the code stream
1856 ;; asm-32 to add a 32 bit integer to the code stream
1857 ;; asm-64 to add a 64 bit integer to the code stream
1858 ;; asm-float64 to add a 64 bit IEEE float to the code stream
1859 ;; asm-string to add a null terminated string to the code stream
1860 ;; asm-label to set a label to the current position in the code stream
1861 ;; asm-align to add enough zero bytes to force alignment
1862 ;; asm-origin to add enough zero bytes to move to a particular address
1863 ;; asm-at-assembly to defer code production to assembly time
1864 ;; asm-listing to add textual information to the listing
1866 (define (asm-begin! start-pos big-endian?)
1867 (set! asm-start-pos start-pos)
1868 (set! asm-big-endian? big-endian?)
1869 (set! asm-code-stream (asm-make-stream))
1870 #f)
1872 ;; (asm-end!) must be called to finalize the assembler.
1874 (define (asm-end!)
1875 (set! asm-code-stream #f)
1876 #f)
1878 ;; (asm-8 n) adds an 8 bit signed or unsigned integer to the code stream.
1880 (define (asm-8 n)
1881 (asm-code-extend (asm-bits-0-to-7 n)))
1883 ;; (asm-16 n) adds a 16 bit signed or unsigned integer to the code stream.
1885 (define (asm-16 n)
1886 (if asm-big-endian?
1887 (begin (asm-8 (asm-bits-8-and-up n)) (asm-8 n))
1888 (begin (asm-8 n) (asm-8 (asm-bits-8-and-up n)))))
1890 ;; (asm-32 n) adds a 32 bit signed or unsigned integer to the code stream.
1892 (define (asm-32 n)
1893 (if asm-big-endian?
1894 (begin (asm-16 (asm-bits-16-and-up n)) (asm-16 n))
1895 (begin (asm-16 n) (asm-16 (asm-bits-16-and-up n)))))
1897 ;; (asm-64 n) adds a 64 bit signed or unsigned integer to the code stream.
1899 (define (asm-64 n)
1900 (if asm-big-endian?
1901 (begin (asm-32 (asm-bits-32-and-up n)) (asm-32 n))
1902 (begin (asm-32 n) (asm-32 (asm-bits-32-and-up n)))))
1904 ;; (asm-float64 n) adds a 64 bit IEEE floating point number to the code stream.
1906 (define (asm-float64 n)
1907 (asm-64 (asm-float->bits n)))
1909 ;; (asm-string str) adds a null terminated string to the code stream.
1911 (define (asm-string str)
1912 (let ((len (string-length str)))
1913 (let loop ((i 0))
1914 (if (< i len)
1915 (begin
1916 (asm-8 (char->integer (string-ref str i)))
1917 (loop (+ i 1)))
1918 (asm-8 0)))))
1920 ;; (asm-make-label id) creates a new label object. A label can
1921 ;; be queried with "asm-label-pos" to obtain the label's position
1922 ;; relative to the start of the code stream (i.e. "start-pos").
1923 ;; The argument "id" gives a name to the label (not necessarily
1924 ;; unique) and is only needed for debugging purposes.
1926 (define (asm-make-label id)
1927 (vector 'LABEL #f id))
1929 ;; (asm-label label-obj) sets the label to the current position in the
1930 ;; code stream.
1932 (define (asm-label label-obj)
1933 (if (vector-ref label-obj 1)
1934 (compiler-internal-error
1935 "asm-label, label multiply defined" (asm-label-id label-obj))
1936 (begin
1937 (vector-set! label-obj 1 0)
1938 (asm-code-extend label-obj))))
1940 ;; (asm-label-id label-obj) returns the identifier of the label object.
1942 (define (asm-label-id label-obj)
1943 (vector-ref label-obj 2))
1945 ;; (asm-label-pos label-obj) returns the position of the label
1946 ;; relative to the start of the code stream (i.e. "start-pos").
1947 ;; This procedure can only be called at assembly time (i.e.
1948 ;; within the call to "asm-assemble") or after assembly time
1949 ;; for labels declared prior to assembly time with "asm-label".
1950 ;; A label declared at assembly time can only be queried after
1951 ;; assembly time. Moreover, at assembly time the position of a
1952 ;; label may vary from one call to the next due to the actions
1953 ;; of the assembler.
1955 (define (asm-label-pos label-obj)
1956 (let ((pos (vector-ref label-obj 1)))
1957 (if pos
1958 pos
1959 (compiler-internal-error
1960 "asm-label-pos, undefined label" (asm-label-id label-obj)))))
1962 ;; (asm-align multiple offset) adds enough zero bytes to the code
1963 ;; stream to force alignment to the next address congruent to
1964 ;; "offset" modulo "multiple".
1966 (define (asm-align multiple offset)
1967 (asm-at-assembly
1968 (lambda (self)
1969 (modulo (- multiple (- self offset)) multiple))
1970 (lambda (self)
1971 (let loop ((n (modulo (- multiple (- self offset)) multiple)))
1972 (if (> n 0)
1973 (begin
1974 (asm-8 0)
1975 (loop (- n 1))))))))
1977 ;; (asm-origin address) adds enough zero bytes to the code stream to move
1978 ;; to the address "address".
1980 (define (asm-origin address)
1981 (asm-at-assembly
1982 (lambda (self)
1983 (- address self))
1984 (lambda (self)
1985 (let ((len (- address self)))
1986 (if (< len 0)
1987 (compiler-internal-error "asm-origin, can't move back")
1988 (let loop ((n len))
1989 (if (> n 0)
1990 (begin
1991 (asm-8 0)
1992 (loop (- n 1))))))))))
1994 ;; (asm-at-assembly . procs) makes it possible to defer code
1995 ;; production to assembly time. A useful application is to generate
1996 ;; position dependent and span dependent code sequences. This
1997 ;; procedure must be passed an even number of procedures. All odd
1998 ;; indexed procedures (including the first procedure) are called "check"
1999 ;; procedures. The even indexed procedures are the "production"
2000 ;; procedures which, when called, produce a particular code sequence.
2001 ;; A check procedure decides if, given the current state of assembly
2002 ;; (in particular the current positioning of the labels), the code
2003 ;; produced by the corresponding production procedure is valid.
2004 ;; If the code is not valid, the check procedure must return #f.
2005 ;; If the code is valid, the check procedure must return the length
2006 ;; of the code sequence in bytes. The assembler will try each check
2007 ;; procedure in order until it finds one that does not return #f
2008 ;; (the last check procedure must never return #f). For convenience,
2009 ;; the current position in the code sequence is passed as the single
2010 ;; argument of check and production procedures.
2011 ;;
2012 ;; Here is a sample call of "asm-at-assembly" to produce the
2013 ;; shortest branch instruction to branch to label "x" for a
2014 ;; hypothetical processor:
2015 ;;
2016 ;; (asm-at-assembly
2017 ;;
2018 ;; (lambda (self) ; first check procedure
2019 ;; (let ((dist (- (asm-label-pos x) self)))
2020 ;; (if (and (>= dist -128) (<= dist 127)) ; short branch possible?
2021 ;; 2
2022 ;; #f)))
2023 ;;
2024 ;; (lambda (self) ; first production procedure
2025 ;; (asm-8 #x34) ; branch opcode for 8 bit displacement
2026 ;; (asm-8 (- (asm-label-pos x) self)))
2027 ;;
2028 ;; (lambda (self) 5) ; second check procedure
2029 ;;
2030 ;; (lambda (self) ; second production procedure
2031 ;; (asm-8 #x35) ; branch opcode for 32 bit displacement
2032 ;; (asm-32 (- (asm-label-pos x) self))))
2034 (define (asm-at-assembly . procs)
2035 (asm-code-extend (vector 'DEFERRED procs)))
2037 ;; (asm-listing text) adds text to the right side of the listing.
2038 ;; The atoms in "text" will be output using "display" (lists are
2039 ;; traversed recursively). The listing is generated by calling
2040 ;; "asm-display-listing".
2042 (define (asm-listing text)
2043 (asm-code-extend (vector 'LISTING text)))
2045 ;; (asm-assemble) assembles the code stream. After assembly, the
2046 ;; label objects will be set to their final position and the
2047 ;; alignment bytes and the deferred code will have been produced. It
2048 ;; is possible to extend the code stream after assembly. However, if
2049 ;; any of the procedures "asm-label", "asm-align", and
2050 ;; "asm-at-assembly" are called, the code stream will have to be
2051 ;; assembled once more.
2053 (define (asm-assemble)
2054 (let ((fixup-lst (asm-pass1)))
2056 (let loop1 ()
2057 (let loop2 ((lst fixup-lst)
2058 (changed? #f)
2059 (pos asm-start-pos))
2060 (if (null? lst)
2061 (if changed? (loop1))
2062 (let* ((fixup (car lst))
2063 (pos (+ pos (car fixup)))
2064 (curr (cdr fixup))
2065 (x (car curr)))
2066 (if (eq? (vector-ref x 0) 'LABEL)
2067 ; LABEL
2068 (if (= (vector-ref x 1) pos)
2069 (loop2 (cdr lst) changed? pos)
2070 (begin
2071 (vector-set! x 1 pos)
2072 (loop2 (cdr lst) #t pos)))
2073 ; DEFERRED
2074 (let loop3 ()
2075 (let ((n ((car (vector-ref x 1)) pos)))
2076 (if n
2077 (loop2 (cdr lst) changed? (+ pos n))
2078 (begin
2079 (vector-set! x 1 (cddr (vector-ref x 1)))
2080 (loop3))))))))))
2082 (let loop4 ((prev asm-code-stream)
2083 (curr (cdr asm-code-stream))
2084 (pos asm-start-pos))
2085 (if (null? curr)
2086 (set-car! asm-code-stream prev)
2087 (let ((x (car curr))
2088 (next (cdr curr)))
2089 (if (vector? x)
2090 (let ((kind (vector-ref x 0)))
2091 (cond ((eq? kind 'LABEL)
2092 (let ((final-pos (vector-ref x 1)))
2093 (if final-pos
2094 (if (not (= pos final-pos))
2095 (compiler-internal-error
2096 "asm-assemble, inconsistency detected"))
2097 (vector-set! x 1 pos))
2098 (set-cdr! prev next)
2099 (loop4 prev next pos)))
2100 ((eq? kind 'DEFERRED)
2101 (let ((temp asm-code-stream))
2102 (set! asm-code-stream (asm-make-stream))
2103 ((cadr (vector-ref x 1)) pos)
2104 (let ((tail (car asm-code-stream)))
2105 (set-cdr! tail next)
2106 (let ((head (cdr asm-code-stream)))
2107 (set-cdr! prev head)
2108 (set! asm-code-stream temp)
2109 (loop4 prev head pos)))))
2110 (else
2111 (loop4 curr next pos))))
2112 (loop4 curr next (+ pos 1))))))))
2114 ;; (asm-display-listing port) produces a listing of the code stream
2115 ;; on the given output port. The bytes generated are shown in
2116 ;; hexadecimal on the left side of the listing and the right side
2117 ;; of the listing contains the text inserted by "asm-listing".
2119 (define (asm-display-listing port)
2121 (define text-col 24)
2122 (define pos-width 6)
2123 (define byte-width 2)
2125 (define (output text)
2126 (cond ((null? text))
2127 ((pair? text)
2128 (output (car text))
2129 (output (cdr text)))
2130 (else
2131 (display text port))))
2133 (define (print-hex n)
2134 (display (string-ref "0123456789ABCDEF" n) port))
2136 (define (print-byte n)
2137 (print-hex (quotient n 16))
2138 (print-hex (modulo n 16)))
2140 (define (print-pos n)
2141 (if (< n 0)
2142 (display " " port)
2143 (begin
2144 (print-byte (quotient n #x10000))
2145 (print-byte (modulo (quotient n #x100) #x100))
2146 (print-byte (modulo n #x100)))))
2148 (let loop1 ((lst (cdr asm-code-stream)) (pos asm-start-pos) (col 0))
2149 (if (null? lst)
2150 (if (> col 0)
2151 (newline port))
2152 (let ((x (car lst)))
2153 (if (vector? x)
2154 (let ((kind (vector-ref x 0)))
2155 (cond ((eq? kind 'LISTING)
2156 (let loop2 ((col col))
2157 (if (< col text-col)
2158 (begin
2159 (display (integer->char 9) port)
2160 (loop2 (* 8 (+ (quotient col 8) 1))))))
2161 (output (vector-ref x 1))
2162 (newline port)
2163 (loop1 (cdr lst) pos 0))
2164 (else
2165 (compiler-internal-error
2166 "asm-display-listing, code stream not assembled"))))
2167 (if (or (= col 0) (>= col (- text-col byte-width)))
2168 (begin
2169 (if (not (= col 0)) (newline port))
2170 (print-pos pos)
2171 (display " " port)
2172 (print-byte x)
2173 (loop1 (cdr lst) (+ pos 1) (+ (+ pos-width 1) byte-width)))
2174 (begin
2175 (print-byte x)
2176 (loop1 (cdr lst) (+ pos 1) (+ col byte-width)))))))))
2178 ;; (asm-write-code filename) outputs the code stream (i.e. the sequence
2179 ;; of bytes produced) on the named file.
2181 (define (asm-write-code filename)
2182 (with-output-to-file filename
2183 (lambda ()
2184 (let loop ((lst (cdr asm-code-stream)))
2185 (if (not (null? lst))
2186 (let ((x (car lst)))
2187 (if (vector? x)
2188 (let ((kind (vector-ref x 0)))
2189 (if (not (eq? kind 'LISTING))
2190 (compiler-internal-error
2191 "asm-write-code, code stream not assembled"))
2192 (loop (cdr lst)))
2193 (begin
2194 (write-char (integer->char x))
2195 (loop (cdr lst))))))))))
2197 (define (asm-write-hex-file filename)
2198 (with-output-to-file filename
2199 (lambda ()
2201 (define (print-hex n)
2202 (display (string-ref "0123456789ABCDEF" n)))
2204 (define (print-byte n)
2205 (print-hex (quotient n 16))
2206 (print-hex (modulo n 16)))
2208 (define (print-line type addr bytes)
2209 (let ((n (length bytes))
2210 (addr-hi (quotient addr 256))
2211 (addr-lo (modulo addr 256)))
2212 (display ":")
2213 (print-byte n)
2214 (print-byte addr-hi)
2215 (print-byte addr-lo)
2216 (print-byte type)
2217 (for-each print-byte bytes)
2218 (let ((sum
2219 (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
2220 (print-byte sum)
2221 (newline))))
2223 (let loop ((lst (cdr asm-code-stream))
2224 (pos asm-start-pos)
2225 (rev-bytes '()))
2226 (if (not (null? lst))
2227 (let ((x (car lst)))
2228 (if (vector? x)
2229 (let ((kind (vector-ref x 0)))
2230 (if (not (eq? kind 'LISTING))
2231 (compiler-internal-error
2232 "asm-write-hex-file, code stream not assembled"))
2233 (loop (cdr lst)
2234 pos
2235 rev-bytes))
2236 (let ((new-pos
2237 (+ pos 1))
2238 (new-rev-bytes
2239 (cons x
2240 (if (= (modulo pos 16) 0)
2241 (begin
2242 (print-line 0
2243 (- pos (length rev-bytes))
2244 (reverse rev-bytes))
2245 '())
2246 rev-bytes))))
2247 (loop (cdr lst)
2248 new-pos
2249 new-rev-bytes))))
2250 (begin
2251 (if (not (null? rev-bytes))
2252 (print-line 0
2253 (- pos (length rev-bytes))
2254 (reverse rev-bytes)))
2255 (print-line 1 0 '())
2256 (if #t
2257 (begin
2258 (display (- pos asm-start-pos) ##stderr-port)
2259 (display " bytes\n" ##stderr-port)))))))))
2261 ;; Utilities.
2263 (define asm-start-pos #f) ; start position of the code stream
2264 (define asm-big-endian? #f) ; endianness to use
2265 (define asm-code-stream #f) ; current code stream
2267 (define (asm-make-stream) ; create an empty stream
2268 (let ((x (cons '() '())))
2269 (set-car! x x)
2270 x))
2272 (define (asm-code-extend item) ; add an item at the end of current code stream
2273 (let* ((stream asm-code-stream)
2274 (tail (car stream))
2275 (cell (cons item '())))
2276 (set-cdr! tail cell)
2277 (set-car! stream cell)))
2279 (define (asm-pass1) ; construct fixup list and make first label assignment
2280 (let loop ((curr (cdr asm-code-stream))
2281 (fixup-lst '())
2282 (span 0)
2283 (pos asm-start-pos))
2284 (if (null? curr)
2285 (reverse fixup-lst)
2286 (let ((x (car curr)))
2287 (if (vector? x)
2288 (let ((kind (vector-ref x 0)))
2289 (cond ((eq? kind 'LABEL)
2290 (vector-set! x 1 pos) ; first approximation of position
2291 (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
2292 ((eq? kind 'DEFERRED)
2293 (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
2294 (else
2295 (loop (cdr curr) fixup-lst span pos))))
2296 (loop (cdr curr) fixup-lst (+ span 1) (+ pos 1)))))))
2298 ;(##declare (generic))
2300 (define (asm-bits-0-to-7 n) ; return bits 0 to 7 of a signed integer
2301 (modulo n #x100))
2303 (define (asm-bits-8-and-up n) ; return bits 8 and up of a signed integer
2304 (if (>= n 0)
2305 (quotient n #x100)
2306 (- (quotient (+ n 1) #x100) 1)))
2308 (define (asm-bits-16-and-up n) ; return bits 16 and up of a signed integer
2309 (if (>= n 0)
2310 (quotient n #x10000)
2311 (- (quotient (+ n 1) #x10000) 1)))
2313 (define (asm-bits-32-and-up n) ; return bits 32 and up of a signed integer
2314 (if (>= n 0)
2315 (quotient n #x100000000)
2316 (- (quotient (+ n 1) #x100000000) 1)))
2318 ; The following procedures convert floating point numbers into their
2319 ; machine representation. They perform bignum and flonum arithmetic.
2321 (define (asm-float->inexact-exponential-format x)
2323 (define (exp-form-pos x y i)
2324 (let ((i*2 (+ i i)))
2325 (let ((z (if (and (not (< asm-ieee-e-bias i*2))
2326 (not (< x y)))
2327 (exp-form-pos x (* y y) i*2)
2328 (cons x 0))))
2329 (let ((a (car z)) (b (cdr z)))
2330 (let ((i+b (+ i b)))
2331 (if (and (not (< asm-ieee-e-bias i+b))
2332 (not (< a y)))
2333 (begin
2334 (set-car! z (/ a y))
2335 (set-cdr! z i+b)))
2336 z)))))
2338 (define (exp-form-neg x y i)
2339 (let ((i*2 (+ i i)))
2340 (let ((z (if (and (< i*2 asm-ieee-e-bias-minus-1)
2341 (< x y))
2342 (exp-form-neg x (* y y) i*2)
2343 (cons x 0))))
2344 (let ((a (car z)) (b (cdr z)))
2345 (let ((i+b (+ i b)))
2346 (if (and (< i+b asm-ieee-e-bias-minus-1)
2347 (< a y))
2348 (begin
2349 (set-car! z (/ a y))
2350 (set-cdr! z i+b)))
2351 z)))))
2353 (define (exp-form x)
2354 (if (< x asm-inexact-+1)
2355 (let ((z (exp-form-neg x asm-inexact-+1/2 1)))
2356 (set-car! z (* asm-inexact-+2 (car z)))
2357 (set-cdr! z (- -1 (cdr z)))
2358 z)
2359 (exp-form-pos x asm-inexact-+2 1)))
2361 (if (negative? x)
2362 (let ((z (exp-form (- asm-inexact-0 x))))
2363 (set-car! z (- asm-inexact-0 (car z)))
2364 z)
2365 (exp-form x)))
2367 (define (asm-float->exact-exponential-format x)
2368 (let ((z (asm-float->inexact-exponential-format x)))
2369 (let ((y (car z)))
2370 (cond ((not (< y asm-inexact-+2))
2371 (set-car! z asm-ieee-+m-min)
2372 (set-cdr! z asm-ieee-e-bias-plus-1))
2373 ((not (< asm-inexact--2 y))
2374 (set-car! z asm-ieee--m-min)
2375 (set-cdr! z asm-ieee-e-bias-plus-1))
2376 (else
2377 (set-car! z
2378 (truncate (inexact->exact (* (car z) asm-inexact-m-min))))))
2379 (set-cdr! z (- (cdr z) asm-ieee-m-bits))
2380 z)))
2382 (define (asm-float->bits x) ; returns the 64 bit integer encoding the float "x"
2384 (define (bits a b)
2385 (if (< a asm-ieee-+m-min)
2386 a
2387 (+ (- a asm-ieee-+m-min)
2388 (* (+ (+ b asm-ieee-m-bits) asm-ieee-e-bias)
2389 asm-ieee-+m-min))))
2391 (let ((z (asm-float->exact-exponential-format x)))
2392 (let ((a (car z)) (b (cdr z)))
2393 (if (negative? a)
2394 (+ asm-ieee-sign-bit (bits (- 0 a) b))
2395 (bits a b)))))
2397 ; Parameters for ANSI-IEEE Std 754-1985 representation of
2398 ; doubles (i.e. 64 bit floating point numbers):
2400 (define asm-ieee-m-bits 52)
2401 (define asm-ieee-e-bits 11)
2402 (define asm-ieee-+m-min 4503599627370496) ; (expt 2 asm-ieee-m-bits)
2403 (define asm-ieee--m-min -4503599627370496) ; (- asm-ieee-+m-min)
2404 (define asm-ieee-sign-bit #x8000000000000000); (expt 2 (+ asm-ieee-e-bits asm-ieee-m-bits))
2406 (define asm-ieee-e-bias 1023) ; (- (expt 2 (- asm-ieee-e-bits 1)) 1)
2407 (define asm-ieee-e-bias-plus-1 1024) ; (+ asm-ieee-e-bias 1)
2408 (define asm-ieee-e-bias-minus-1 1022) ; (- asm-ieee-e-bias 1)
2410 (define asm-inexact-m-min (exact->inexact asm-ieee-+m-min))
2411 (define asm-inexact-+2 (exact->inexact 2))
2412 (define asm-inexact--2 (exact->inexact -2))
2413 (define asm-inexact-+1 (exact->inexact 1))
2414 (define asm-inexact-+1/2 (exact->inexact (/ 1 2)))
2415 (define asm-inexact-0 (exact->inexact 0))
2417 ;------------------------------------------------------------------------------
2419 (define min-fixnum-encoding 3)
2420 (define min-fixnum -5)
2421 (define max-fixnum 40)
2422 (define min-rom-encoding (+ min-fixnum-encoding (- max-fixnum min-fixnum) 1))
2423 (define min-ram-encoding 128) ;; TODO change ?
2424 (define max-ram-encoding 8191)
2426 (define code-start #x5000)
2428 (define (predef-constants) (list))
2430 (define (predef-globals) (list))
2432 (define (encode-direct obj)
2433 (cond ((eq? obj #f)
2434 0)
2435 ((eq? obj #t)
2436 1)
2437 ((eq? obj '())
2438 2)
2439 ((and (integer? obj)
2440 (exact? obj)
2441 (>= obj min-fixnum)
2442 (<= obj max-fixnum))
2443 (+ obj (- min-fixnum-encoding min-fixnum)))
2444 (else
2445 #f)))
2447 (define (translate-constant obj)
2448 (if (char? obj)
2449 (char->integer obj)
2450 obj))
2452 (define (encode-constant obj constants) ;; TODO FOOBAR, this should return a 12 bit value
2453 (let ((o (translate-constant obj)))
2454 (let ((e (encode-direct o)))
2455 (if e
2456 e
2457 (let ((x (assoc o constants))) ;; TODO was assq
2458 (if x
2459 (vector-ref (cdr x) 0)
2460 (compiler-error "unknown object" obj)))))))
2462 (define (add-constant obj constants from-code? cont) ;; TODO where does the actual encoding actually take place ? at assembly time ? probably
2463 (let ((o (translate-constant obj)))
2464 (let ((e (encode-direct o)))
2465 (if e
2466 (cont constants)
2467 (let ((x (assoc o constants))) ;; TODO was assq
2468 (if x
2469 (begin
2470 (if from-code?
2471 (vector-set! (cdr x) 2 (+ (vector-ref (cdr x) 2) 1)))
2472 (cont constants))
2473 (let* ((descr
2474 (vector #f
2475 (asm-make-label 'constant)
2476 (if from-code? 1 0)
2477 #f))
2478 (new-constants
2479 (cons (cons o descr)
2480 constants)))
2481 (cond ((pair? o) ;; TODO what to do in the case of a pair of, for example, fixnums, where only one object is actually used ?
2482 (add-constants (list (car o) (cdr o))
2483 new-constants
2484 cont))
2485 ((symbol? o)
2486 (cont new-constants))
2487 ((string? o)
2488 (let ((chars (map char->integer (string->list o))))
2489 (vector-set! descr 3 chars)
2490 (add-constant chars
2491 new-constants
2492 #f
2493 cont)))
2494 ((vector? o)
2495 (let ((elems (vector->list o)))
2496 (vector-set! descr 3 elems)
2497 (add-constant elems
2498 new-constants
2499 #f
2500 cont)))
2502 (else
2503 (cont new-constants))))))))))
2505 (define (add-constants objs constants cont)
2506 (if (null? objs)
2507 (cont constants)
2508 (add-constant (car objs)
2509 constants
2510 #f
2511 (lambda (new-constants)
2512 (add-constants (cdr objs)
2513 new-constants
2514 cont)))))
2516 (define (add-global var globals cont) ;; TODO check if mutable, and if not, put as constant
2517 (let ((x (assq var globals)))
2518 (if x
2519 (cont globals)
2520 (let ((new-globals
2521 (cons (cons var (length globals))
2522 globals)))
2523 (cont new-globals)))))
2525 (define (sort-constants constants)
2526 (let ((csts
2527 (sort-list constants
2528 (lambda (x y)
2529 (> (vector-ref (cdr x) 2)
2530 (vector-ref (cdr y) 2))))))
2531 (let loop ((i min-rom-encoding)
2532 (lst csts))
2533 (if (null? lst)
2534 (if (> i min-ram-encoding)
2535 (compiler-error "too many constants")
2536 csts) ;; TODO do some constant propagation, actually, more for globals ?
2537 (begin
2538 (vector-set! (cdr (car lst)) 0 i)
2539 (loop (+ i 1)
2540 (cdr lst)))))))
2542 (define assemble
2543 (lambda (code hex-filename)
2544 (let loop1 ((lst code)
2545 (constants (predef-constants))
2546 (globals (predef-globals))
2547 (labels (list)))
2548 (if (pair? lst)
2550 (let ((instr (car lst)))
2551 (cond ((number? instr)
2552 (loop1 (cdr lst)
2553 constants
2554 globals
2555 (cons (cons instr (asm-make-label 'label))
2556 labels)))
2557 ((eq? (car instr) 'push-constant)
2558 (add-constant (cadr instr)
2559 constants
2560 #t
2561 (lambda (new-constants)
2562 (loop1 (cdr lst)
2563 new-constants
2564 globals
2565 labels))))
2566 ((memq (car instr) '(push-global set-global))
2567 (add-global (cadr instr)
2568 globals
2569 (lambda (new-globals)
2570 (loop1 (cdr lst)
2571 constants
2572 new-globals
2573 labels))))
2574 (else
2575 (loop1 (cdr lst)
2576 constants
2577 globals
2578 labels))))
2580 (let ((constants (sort-constants constants)))
2582 (define (label-instr label opcode)
2583 (asm-at-assembly
2584 (lambda (self)
2585 3) ;; TODO BARF was 2, maybe was length ? seems to be fixed
2586 (lambda (self)
2587 (let ((pos (- (asm-label-pos label) code-start)))
2588 ;; (asm-8 (+ (quotient pos 256) opcode))
2589 ;; TODO do we mess up any offsets ? FOOBAR
2590 (asm-8 opcode)
2591 (asm-8 (quotient pos 256))
2592 (asm-8 (modulo pos 256))))))
2594 (define (push-constant n)
2595 (if (<= n 31)
2596 (asm-8 (+ #x00 n))
2597 (begin
2598 (asm-8 #xfc)
2599 (asm-8 (quotient n 256))
2600 (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
2602 (define (push-stack n)
2603 (if (> n 31)
2604 (compiler-error "stack is too deep")
2605 (asm-8 (+ #x20 n))))
2607 (define (push-global n)
2608 (asm-8 (+ #x40 n)) ;; TODO maybe do the same as for csts, have a push-long-global to have more ?
2609 ;; (if (> n 15)
2610 ;; (compiler-error "too many global variables")
2611 ;; (asm-8 (+ #x40 n)))
2612 ) ;; TODO actually inline most, or put as csts
2614 (define (set-global n)
2615 (asm-8 (+ #x50 n))
2616 ;; (if (> n 15) ;; ADDED prevented the stack from compiling
2617 ;; (compiler-error "too many global variables")
2618 ;; (asm-8 (+ #x50 n)))
2619 )
2621 (define (call n)
2622 (if (> n 15)
2623 (compiler-error "call has too many arguments")
2624 (asm-8 (+ #x60 n))))
2626 (define (jump n)
2627 (if (> n 15)
2628 (compiler-error "call has too many arguments")
2629 (asm-8 (+ #x70 n))))
2631 (define (call-toplevel label) ;; TODO use 8-bit opcodes for these
2632 (label-instr label #x80))
2634 (define (jump-toplevel label)
2635 (label-instr label #x90))
2637 (define (goto label)
2638 (label-instr label #xa0))
2640 (define (goto-if-false label)
2641 (label-instr label #xb0))
2643 (define (closure label)
2644 (label-instr label #xc0)) ;; FOOBAR change here ?
2646 (define (prim n)
2647 (asm-8 (+ #xd0 n)))
2649 (define (prim.number?) (prim 0))
2650 (define (prim.+) (prim 1))
2651 (define (prim.-) (prim 2))
2652 (define (prim.*) (prim 3))
2653 (define (prim.quotient) (prim 4))
2654 (define (prim.remainder) (prim 5))
2655 (define (prim.neg) (prim 6))
2656 (define (prim.=) (prim 7))
2657 (define (prim.<) (prim 8))
2658 (define (prim.ior) (prim 9))
2659 (define (prim.>) (prim 10))
2660 (define (prim.xor) (prim 11))
2661 (define (prim.pair?) (prim 12))
2662 (define (prim.cons) (prim 13))
2663 (define (prim.car) (prim 14))
2664 (define (prim.cdr) (prim 15))
2665 (define (prim.set-car!) (prim 16))
2666 (define (prim.set-cdr!) (prim 17))
2667 (define (prim.null?) (prim 18))
2668 (define (prim.eq?) (prim 19))
2669 (define (prim.not) (prim 20))
2670 (define (prim.get-cont) (prim 21))
2671 (define (prim.graft-to-cont) (prim 22))
2672 (define (prim.return-to-cont) (prim 23))
2673 (define (prim.halt) (prim 24))
2674 (define (prim.symbol?) (prim 25))
2675 (define (prim.string?) (prim 26))
2676 (define (prim.string->list) (prim 27))
2677 (define (prim.list->string) (prim 28))
2679 (define (prim.print) (prim 32))
2680 (define (prim.clock) (prim 33))
2681 (define (prim.motor) (prim 34))
2682 (define (prim.led) (prim 35))
2683 (define (prim.led2-color) (prim 36))
2684 (define (prim.getchar-wait) (prim 37))
2685 (define (prim.putchar) (prim 38))
2686 (define (prim.beep) (prim 39))
2687 (define (prim.adc) (prim 40))
2688 (define (prim.dac) (prim 41))
2689 (define (prim.sernum) (prim 42)) ;; TODO necessary ?
2691 (define (prim.shift) (prim 45))
2692 (define (prim.pop) (prim 46))
2693 (define (prim.return) (prim 47))
2695 (define big-endian? #f)
2697 (asm-begin! code-start #f)
2699 (asm-8 #xfb)
2700 (asm-8 #xd7)
2701 (asm-8 (length constants))
2702 (asm-8 0)
2704 (pp (list constants: constants globals: globals)) ;; TODO debug
2706 (for-each
2707 (lambda (x)
2708 (let* ((descr (cdr x))
2709 (label (vector-ref descr 1))
2710 (obj (car x)))
2711 (asm-label label)
2712 ;; see the vm source for a description of encodings
2713 (cond ((and (integer? obj) (exact? obj))
2714 (asm-8 0)
2715 (asm-8 (bitwise-and (arithmetic-shift obj -16) 255))
2716 (asm-8 (bitwise-and (arithmetic-shift obj -8) 255))
2717 (asm-8 (bitwise-and obj 255)))
2718 ((pair? obj)
2719 (let ((obj-car (encode-constant (car obj) constants))
2720 (obj-cdr (encode-constant (cdr obj) constants)))
2721 (asm-8 (+ #x80 (arithmetic-shift obj-car -8)))
2722 (asm-8 (bitwise-and obj-car #xff))
2723 (asm-8 (+ 0 (arithmetic-shift obj-cdr -8)))
2724 (asm-8 (bitwise-and obj-cdr #xff))))
2725 ((symbol? obj)
2726 (asm-8 #x80)
2727 (asm-8 0)
2728 (asm-8 #x20)
2729 (asm-8 0))
2730 ((string? obj)
2731 (let ((obj-enc (encode-constant (vector-ref descr 3)
2732 constants)))
2733 (asm-8 (+ #x80 (arithmetic-shift obj-enc -8)))
2734 (asm-8 (bitwise-and obj-enc #xff))
2735 (asm-8 #x40)
2736 (asm-8 0)))
2737 ((vector? obj)
2738 (let ((obj-enc (encode-constant (vector-ref descr 3)
2739 constants)))
2740 (asm-8 (+ #x80 (arithmetic-shift obj-enc -8)))
2741 (asm-8 (bitwise-and obj-enc #xff))
2742 (asm-8 #x60)
2743 (asm-8 0)))
2744 (else
2745 (compiler-error "unknown object type" obj)))))
2746 constants)
2748 (let loop2 ((lst code))
2749 (if (pair? lst)
2750 (let ((instr (car lst)))
2752 (cond ((number? instr)
2753 (let ((label (cdr (assq instr labels))))
2754 (asm-label label)))
2756 ((eq? (car instr) 'entry)
2757 (let ((np (cadr instr))
2758 (rest? (caddr instr)))
2759 (asm-8 (if rest? (- np) np))))
2761 ((eq? (car instr) 'push-constant) ;; TODO FOOBAR 12 bits for constants now (actually, I don't think it matters here)
2762 (let ((n (encode-constant (cadr instr) constants)))
2763 (push-constant n)))
2765 ((eq? (car instr) 'push-stack)
2766 (push-stack (cadr instr)))
2768 ((eq? (car instr) 'push-global)
2769 (push-global (cdr (assq (cadr instr) globals))))
2771 ((eq? (car instr) 'set-global)
2772 (set-global (cdr (assq (cadr instr) globals))))
2774 ((eq? (car instr) 'call)
2775 (call (cadr instr)))
2777 ((eq? (car instr) 'jump)
2778 (jump (cadr instr)))
2780 ((eq? (car instr) 'call-toplevel)
2781 (let ((label (cdr (assq (cadr instr) labels))))
2782 (call-toplevel label)))
2784 ((eq? (car instr) 'jump-toplevel)
2785 (let ((label (cdr (assq (cadr instr) labels))))
2786 (jump-toplevel label)))
2788 ((eq? (car instr) 'goto)
2789 (let ((label (cdr (assq (cadr instr) labels))))
2790 (goto label)))
2792 ((eq? (car instr) 'goto-if-false)
2793 (let ((label (cdr (assq (cadr instr) labels))))
2794 (goto-if-false label)))
2796 ((eq? (car instr) 'closure)
2797 (let ((label (cdr (assq (cadr instr) labels))))
2798 (closure label)))
2800 ((eq? (car instr) 'prim)
2801 (case (cadr instr)
2802 ((#%number?) (prim.number?))
2803 ((#%+) (prim.+))
2804 ((#%-) (prim.-))
2805 ((#%*) (prim.*))
2806 ((#%quotient) (prim.quotient))
2807 ((#%remainder) (prim.remainder))
2808 ((#%neg) (prim.neg))
2809 ((#%=) (prim.=))
2810 ((#%<) (prim.<))
2811 ((#%ior) (prim.ior))
2812 ((#%>) (prim.>))
2813 ((#%xor) (prim.xor))
2814 ((#%pair?) (prim.pair?))
2815 ((#%cons) (prim.cons))
2816 ((#%car) (prim.car))
2817 ((#%cdr) (prim.cdr))
2818 ((#%set-car!) (prim.set-car!))
2819 ((#%set-cdr!) (prim.set-cdr!))
2820 ((#%null?) (prim.null?))
2821 ((#%eq?) (prim.eq?))
2822 ((#%not) (prim.not))
2823 ((#%get-cont) (prim.get-cont))
2824 ((#%graft-to-cont) (prim.graft-to-cont))
2825 ((#%return-to-cont) (prim.return-to-cont))
2826 ((#%halt) (prim.halt))
2827 ((#%symbol?) (prim.symbol?))
2828 ((#%string?) (prim.string?))
2829 ((#%string->list) (prim.string->list))
2830 ((#%list->string) (prim.list->string))
2832 ((#%print) (prim.print))
2833 ((#%clock) (prim.clock))
2834 ((#%motor) (prim.motor))
2835 ((#%led) (prim.led))
2836 ((#%led2-color) (prim.led2-color))
2837 ((#%getchar-wait) (prim.getchar-wait))
2838 ((#%putchar) (prim.putchar))
2839 ((#%beep) (prim.beep))
2840 ((#%adc) (prim.adc))
2841 ((#%dac) (prim.dac))
2842 ((#%sernum) (prim.sernum))
2843 (else
2844 (compiler-error "unknown primitive" (cadr instr)))))
2846 ((eq? (car instr) 'return)
2847 (prim.return))
2849 ((eq? (car instr) 'pop)
2850 (prim.pop))
2852 ((eq? (car instr) 'shift)
2853 (prim.shift))
2855 (else
2856 (compiler-error "unknown instruction" instr)))
2858 (loop2 (cdr lst)))))
2860 (asm-assemble)
2862 (asm-write-hex-file hex-filename)
2864 (asm-end!))))))
2866 (define execute
2867 (lambda (hex-filename)
2868 '
2869 (if #f
2870 (begin
2871 (shell-command "gcc -o picobit-vm picobit-vm.c")
2872 (shell-command (string-append "./picobit-vm " hex-filename)))
2873 (shell-command (string-append "./robot . 1 " hex-filename)))))
2875 (define (sort-list l <?)
2877 (define (mergesort l)
2879 (define (merge l1 l2)
2880 (cond ((null? l1) l2)
2881 ((null? l2) l1)
2882 (else
2883 (let ((e1 (car l1)) (e2 (car l2)))
2884 (if (<? e1 e2)
2885 (cons e1 (merge (cdr l1) l2))
2886 (cons e2 (merge l1 (cdr l2))))))))
2888 (define (split l)
2889 (if (or (null? l) (null? (cdr l)))
2890 l
2891 (cons (car l) (split (cddr l)))))
2893 (if (or (null? l) (null? (cdr l)))
2894 l
2895 (let* ((l1 (mergesort (split l)))
2896 (l2 (mergesort (split (cdr l)))))
2897 (merge l1 l2))))
2899 (mergesort l))
2901 ;------------------------------------------------------------------------------
2903 (define compile
2904 (lambda (filename)
2905 (let* ((node (parse-file filename))
2906 (hex-filename
2907 (string-append
2908 (path-strip-extension filename)
2909 ".hex")))
2911 ; (pp (node->expr node))
2913 (let ((ctx (comp-none node (make-init-context))))
2914 (let ((prog (linearize (optimize-code (context-code ctx)))))
2915 ; (pp (list code: prog env: (context-env ctx)))
2916 (assemble prog hex-filename)
2917 (execute hex-filename))))))
2920 (define main
2921 (lambda (filename)
2922 (compile filename)))
2924 ;------------------------------------------------------------------------------
2926 '
2927 (define (asm-write-hex-file filename)
2928 (with-output-to-file filename
2929 (lambda ()
2931 (define (print-hex n)
2932 (display (string-ref "0123456789ABCDEF" n)))
2934 (define (print-byte n)
2935 (display ", 0x")
2936 (print-hex (quotient n 16))
2937 (print-hex (modulo n 16)))
2939 (define (print-line type addr bytes)
2940 (let ((n (length bytes))
2941 (addr-hi (quotient addr 256))
2942 (addr-lo (modulo addr 256)))
2943 ; (display ":")
2944 ; (print-byte n)
2945 ; (print-byte addr-hi)
2946 ; (print-byte addr-lo)
2947 ; (print-byte type)
2948 (for-each print-byte bytes)
2949 (let ((sum
2950 (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
2951 ; (print-byte sum)
2952 (newline))))
2954 (let loop ((lst (cdr asm-code-stream))
2955 (pos asm-start-pos)
2956 (rev-bytes '()))
2957 (if (not (null? lst))
2958 (let ((x (car lst)))
2959 (if (vector? x)
2960 (let ((kind (vector-ref x 0)))
2961 (if (not (eq? kind 'LISTING))
2962 (compiler-internal-error
2963 "asm-write-hex-file, code stream not assembled"))
2964 (loop (cdr lst)
2965 pos
2966 rev-bytes))
2967 (let ((new-pos
2968 (+ pos 1))
2969 (new-rev-bytes
2970 (cons x
2971 (if (= (modulo pos 8) 0)
2972 (begin
2973 (print-line 0
2974 (- pos (length rev-bytes))
2975 (reverse rev-bytes))
2976 '())
2977 rev-bytes))))
2978 (loop (cdr lst)
2979 new-pos
2980 new-rev-bytes))))
2981 (begin
2982 (if (not (null? rev-bytes))
2983 (print-line 0
2984 (- pos (length rev-bytes))
2985 (reverse rev-bytes)))
2986 (print-line 1 0 '())))))))