| blob | 5320ee2a32c3f498f8384743ec72a66d95d397bd |
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 3 #f #t))
242 (make-var '#%led #t '() '() '() #f (make-primitive 1 #f #t))
243 (make-var '#%getchar-wait #t '() '() '() #f (make-primitive 1 #f #f))
244 (make-var '#%putchar #t '() '() '() #f (make-primitive 1 #f #t))
245 (make-var '#%light #t '() '() '() #f (make-primitive 0 #f #f))
247 (make-var '#%triplet? #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED
248 (make-var '#%triplet #t '() '() '() #f (make-primitive 3 #f #f)) ;; ADDED
249 (make-var '#%fst #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED
250 (make-var '#%snd #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED
251 (make-var '#%trd #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED
253 (make-var '#%readyq #t '() '() '() #f #f)
255 )))
257 (define env-lookup
258 (lambda (env id)
259 (let loop ((lst env) (id id))
260 (let ((b (car lst)))
261 (cond ((and (renaming? b)
262 (assq id (renaming-renamings b)))
263 =>
264 (lambda (x)
265 (loop (cdr lst) (cadr x))))
266 ((and (var? b)
267 (eq? (var-id b) id))
268 b)
269 ((null? (cdr lst))
270 (let ((x (make-var id #t '() '() '() #f #f)))
271 (set-cdr! lst (cons x '()))
272 x))
273 (else
274 (loop (cdr lst) id)))))))
276 (define env-extend
277 (lambda (env ids def)
278 (append (map (lambda (id)
279 (make-var id #f '() '() (list def) #f #f))
280 ids)
281 env)))
283 (define env-extend-renamings
284 (lambda (env renamings)
285 (cons (make-renaming renamings) env)))
287 ;-----------------------------------------------------------------------------
289 ; Parsing.
291 (define parse-program
292 (lambda (expr env)
293 (let ((x (parse-top expr env)))
294 (cond ((null? x)
295 (parse 'value #f env))
296 ((null? (cdr x))
297 (car x))
298 (else
299 (let ((r (make-seq #f x)))
300 (for-each (lambda (y) (node-parent-set! y r)) x)
301 r))))))
303 (define parse-top
304 (lambda (expr env)
305 (cond ((and (pair? expr)
306 (eq? (car expr) 'begin))
307 (parse-top-list (cdr expr) env))
308 ((and (pair? expr)
309 (eq? (car expr) 'hide))
310 (parse-top-hide (cadr expr) (cddr expr) env))
311 ((and (pair? expr)
312 (eq? (car expr) 'rename))
313 (parse-top-rename (cadr expr) (cddr expr) env))
314 ((and (pair? expr)
315 (eq? (car expr) 'define))
316 (let ((var
317 (if (pair? (cadr expr))
318 (car (cadr expr))
319 (cadr expr)))
320 (val
321 (if (pair? (cadr expr))
322 (cons 'lambda (cons (cdr (cadr expr)) (cddr expr)))
323 (caddr expr))))
324 (let* ((var2 (env-lookup env var))
325 (val2 (parse 'value val env))
326 (r (make-def #f (list val2) var2)))
327 (node-parent-set! val2 r)
328 (var-defs-set! var2 (cons r (var-defs var2)))
329 (list r))))
330 (else
331 (list (parse 'value expr env))))))
333 (define parse-top-list
334 (lambda (lst env)
335 (if (pair? lst)
336 (append (parse-top (car lst) env)
337 (parse-top-list (cdr lst) env))
338 '())))
340 (define parse-top-hide
341 (lambda (renamings body env)
342 (append
343 (parse-top-list body
344 (env-extend-renamings env renamings))
345 #|
346 (parse-top-list
347 (map (lambda (x) (list 'define (car x) (cadr x))) renamings)
348 env)
349 |#
350 )))
352 (define parse-top-rename
353 (lambda (renamings body env)
354 (parse-top-list body
355 (env-extend-renamings env renamings))))
357 (define parse
358 (lambda (use expr env)
359 (cond ((self-eval? expr)
360 (make-cst #f '() expr))
361 ((symbol? expr)
362 (let* ((var (env-lookup env expr))
363 (r (make-ref #f '() var)))
364 (var-refs-set! var (cons r (var-refs var)))
365 r))
366 ((and (pair? expr) ;; ADDED, when we have a true macroexpander, get rid
367 (eq? (car expr) 'cond))
368 (parse use
369 `(if ,(caadr expr)
370 (begin ,@(cdadr expr))
371 ,(if (null? (cddr expr))
372 #f
373 `(cond ,@(cddr expr))))
374 env))
375 ((and (pair? expr)
376 (eq? (car expr) 'set!))
377 (let ((var (env-lookup env (cadr expr))))
378 (if (var-global? var)
379 (let* ((val (parse 'value (caddr expr) env))
380 (r (make-set #f (list val) var)))
381 (node-parent-set! val r)
382 (var-sets-set! var (cons r (var-sets var)))
383 r)
384 (compiler-error "set! is only permitted on global variables"))))
385 ((and (pair? expr)
386 (eq? (car expr) 'quote))
387 (make-cst #f '() (cadr expr)))
388 ((and (pair? expr)
389 (eq? (car expr) 'if))
390 (let* ((a (parse 'test (cadr expr) env))
391 (b (parse use (caddr expr) env))
392 (c (if (null? (cdddr expr))
393 (make-cst #f '() #f)
394 (parse use (cadddr expr) env)))
395 (r (make-if #f (list a b c))))
396 (node-parent-set! a r)
397 (node-parent-set! b r)
398 (node-parent-set! c r)
399 r))
400 ((and (pair? expr)
401 (eq? (car expr) 'lambda))
402 (let* ((pattern (cadr expr))
403 (ids (extract-ids pattern))
404 (r (make-prc #f '() #f (has-rest-param? pattern) #f))
405 (new-env (env-extend env ids r))
406 (body (parse-body (cddr expr) new-env)))
407 (prc-params-set! r (map (lambda (id) (env-lookup new-env id)) ids))
408 (node-children-set! r (list body))
409 (node-parent-set! body r)
410 r))
411 ((and (pair? expr)
412 (eq? (car expr) 'begin))
413 (let* ((exprs (map (lambda (x) (parse 'value x env)) (cdr expr)))
414 (r (make-seq #f exprs)))
415 (for-each (lambda (x) (node-parent-set! x r)) exprs)
416 r))
417 ((and (pair? expr)
418 (eq? (car expr) 'let))
419 (if (symbol? (cadr expr))
420 (compiler-error "named let is not implemented")
421 (parse use
422 (cons (cons 'lambda
423 (cons (map car (cadr expr))
424 (cddr expr)))
425 (map cadr (cadr expr)))
426 env)))
427 ((and (pair? expr)
428 (eq? (car expr) 'let*))
429 (if (null? (cadr expr))
430 (parse use
431 (cons 'let (cdr expr))
432 env)
433 (parse use
434 (list 'let
435 (list (list (caar (cadr expr))
436 (cadar (cadr expr))))
437 (cons 'let*
438 (cons (cdr (cadr expr))
439 (cddr expr))))
440 env)))
441 ((and (pair? expr)
442 (eq? (car expr) 'and))
443 (cond ((null? (cdr expr))
444 (parse use
445 #t
446 env))
447 ((null? (cddr expr))
448 (parse use
449 (cadr expr)
450 env))
451 (else
452 (parse use
453 (list 'if
454 (cadr expr)
455 (cons 'and (cddr expr))
456 #f)
457 env))))
458 ((and (pair? expr)
459 (eq? (car expr) 'or))
460 (cond ((null? (cdr expr))
461 (parse use
462 #f
463 env))
464 ((null? (cddr expr))
465 (parse use
466 (cadr expr)
467 env))
468 ((eq? use 'test)
469 (parse use
470 (list 'if
471 (cadr expr)
472 #t
473 (cons 'or (cddr expr)))
474 env))
475 (else
476 (parse use
477 (let ((v (gensym)))
478 (list 'let
479 (list (list v (cadr expr)))
480 (list 'if
481 v
482 v
483 (cons 'or (cddr expr)))))
484 env))))
485 ((and (pair? expr)
486 (memq (car expr)
487 '(quote quasiquote unquote unquote-splicing lambda if
488 set! cond and or case let let* letrec begin do define
489 delay)))
490 (compiler-error "the compiler does not implement the special form" (car expr)))
491 ((pair? expr)
492 (let* ((exprs (map (lambda (x) (parse 'value x env)) expr))
493 (r (make-call #f exprs)))
494 (for-each (lambda (x) (node-parent-set! x r)) exprs)
495 r))
496 (else
497 (compiler-error "unknown expression" expr)))))
499 (define parse-body
500 (lambda (exprs env)
501 (parse 'value (cons 'begin exprs) env)))
503 (define self-eval?
504 (lambda (expr)
505 (or (number? expr)
506 (char? expr)
507 (boolean? expr)
508 (string? expr))))
510 (define extract-ids
511 (lambda (pattern)
512 (if (pair? pattern)
513 (cons (car pattern) (extract-ids (cdr pattern)))
514 (if (symbol? pattern)
515 (cons pattern '())
516 '()))))
518 (define has-rest-param?
519 (lambda (pattern)
520 (if (pair? pattern)
521 (has-rest-param? (cdr pattern))
522 (symbol? pattern))))
524 ;-----------------------------------------------------------------------------
526 ; Compilation context representation.
528 (define-type context
529 code
530 env
531 env2
532 )
534 (define context-change-code
535 (lambda (ctx code)
536 (make-context code
537 (context-env ctx)
538 (context-env2 ctx))))
540 (define context-change-env
541 (lambda (ctx env)
542 (make-context (context-code ctx)
543 env
544 (context-env2 ctx))))
546 (define context-change-env2
547 (lambda (ctx env2)
548 (make-context (context-code ctx)
549 (context-env ctx)
550 env2)))
552 (define make-init-context
553 (lambda ()
554 (make-context (make-init-code)
555 (make-init-env)
556 #f)))
558 (define context-make-label
559 (lambda (ctx)
560 (context-change-code ctx (code-make-label (context-code ctx)))))
562 (define context-last-label
563 (lambda (ctx)
564 (code-last-label (context-code ctx))))
566 (define context-add-bb
567 (lambda (ctx label)
568 (context-change-code ctx (code-add-bb (context-code ctx) label))))
570 (define context-add-instr
571 (lambda (ctx instr)
572 (context-change-code ctx (code-add-instr (context-code ctx) instr))))
574 ; Representation of code.
576 (define-type code
577 last-label
578 rev-bbs
579 )
581 (define-type bb
582 label
583 rev-instrs
584 )
586 (define make-init-code
587 (lambda ()
588 (make-code 0
589 (list (make-bb 0 (list))))))
591 (define code-make-label
592 (lambda (code)
593 (let ((label (+ (code-last-label code) 1)))
594 (make-code label
595 (code-rev-bbs code)))))
597 (define code-add-bb
598 (lambda (code label)
599 (make-code
600 (code-last-label code)
601 (cons (make-bb label '())
602 (code-rev-bbs code)))))
604 (define code-add-instr
605 (lambda (code instr)
606 (let* ((rev-bbs (code-rev-bbs code))
607 (bb (car rev-bbs))
608 (rev-instrs (bb-rev-instrs bb)))
609 (make-code
610 (code-last-label code)
611 (cons (make-bb (bb-label bb)
612 (cons instr rev-instrs))
613 (cdr rev-bbs))))))
615 ; Representation of compile-time stack.
617 (define-type stack
618 size ; number of slots
619 slots ; for each slot, the variable (or #f) contained in the slot
620 )
622 (define make-init-stack
623 (lambda ()
624 (make-stack 0 '())))
626 (define stack-extend
627 (lambda (x nb-slots stk)
628 (let ((size (stack-size stk)))
629 (make-stack
630 (+ size nb-slots)
631 (append (repeat nb-slots x) (stack-slots stk))))))
633 (define stack-discard
634 (lambda (nb-slots stk)
635 (let ((size (stack-size stk)))
636 (make-stack
637 (- size nb-slots)
638 (list-tail (stack-slots stk) nb-slots)))))
640 ; Representation of compile-time environment.
642 (define-type env
643 local
644 closed
645 )
647 (define make-init-env
648 (lambda ()
649 (make-env (make-init-stack)
650 '())))
652 (define env-change-local
653 (lambda (env local)
654 (make-env local
655 (env-closed env))))
657 (define env-change-closed
658 (lambda (env closed)
659 (make-env (env-local env)
660 closed)))
662 (define find-local-var
663 (lambda (var env)
664 (let ((i (pos-in-list var (stack-slots (env-local env)))))
665 (or i
666 (- (+ (pos-in-list var (env-closed env)) 1))))))
668 (define prc->env
669 (lambda (prc)
670 (make-env
671 (let ((params (prc-params prc)))
672 (make-stack (length params)
673 (append (map var-id params) '())))
674 (let ((vars (varset->list (non-global-fv prc))))
675 ; (pp (map var-id vars))
676 (map var-id vars)))))
678 ;-----------------------------------------------------------------------------
680 (define gen-instruction
681 (lambda (instr nb-pop nb-push ctx)
682 (let* ((env
683 (context-env ctx))
684 (stk
685 (stack-extend #f
686 nb-push
687 (stack-discard nb-pop
688 (env-local env)))))
689 (context-add-instr (context-change-env ctx (env-change-local env stk))
690 instr))))
692 (define gen-entry
693 (lambda (nparams rest? ctx)
694 (gen-instruction (list 'entry nparams rest?) 0 0 ctx)))
696 (define gen-push-constant
697 (lambda (val ctx)
698 (gen-instruction (list 'push-constant val) 0 1 ctx)))
700 (define gen-push-unspecified
701 (lambda (ctx)
702 (gen-push-constant #f ctx)))
704 (define gen-push-local-var
705 (lambda (var ctx)
706 ; (pp (list var: var local: (stack-slots (env-local (context-env ctx))) (env-closed (context-env ctx))))
707 (let ((i (find-local-var var (context-env ctx))))
708 (if (>= i 0)
709 (gen-push-stack i ctx)
710 (gen-push-stack (+ (- -1 i) (length (stack-slots (env-local (context-env ctx))))) ctx)))))
712 (define gen-push-stack
713 (lambda (pos ctx)
714 (gen-instruction (list 'push-stack pos) 0 1 ctx)))
716 (define gen-push-global
717 (lambda (var ctx)
718 (gen-instruction (list 'push-global var) 0 1 ctx)))
720 (define gen-set-global
721 (lambda (var ctx)
722 (gen-instruction (list 'set-global var) 1 0 ctx)))
724 (define gen-call
725 (lambda (nargs ctx)
726 (gen-instruction (list 'call nargs) (+ nargs 1) 1 ctx)))
728 (define gen-jump
729 (lambda (nargs ctx)
730 (gen-instruction (list 'jump nargs) (+ nargs 1) 1 ctx)))
732 (define gen-call-toplevel
733 (lambda (nargs id ctx)
734 (gen-instruction (list 'call-toplevel id) nargs 1 ctx)))
736 (define gen-jump-toplevel
737 (lambda (nargs id ctx)
738 (gen-instruction (list 'jump-toplevel id) nargs 1 ctx)))
740 (define gen-goto
741 (lambda (label ctx)
742 (gen-instruction (list 'goto label) 0 0 ctx)))
744 (define gen-goto-if-false
745 (lambda (label-false label-true ctx)
746 (gen-instruction (list 'goto-if-false label-false label-true) 1 0 ctx)))
748 (define gen-closure
749 (lambda (label-entry ctx)
750 (gen-instruction (list 'closure label-entry) 2 1 ctx)))
752 (define gen-prim
753 (lambda (id nargs unspec-result? ctx)
754 (gen-instruction
755 (list 'prim id)
756 nargs
757 (if unspec-result? 0 1)
758 ctx)))
760 (define gen-shift
761 (lambda (n ctx)
762 (if (> n 0)
763 (gen-instruction (list 'shift) 1 0 (gen-shift (- n 1) ctx))
764 ctx)))
766 (define gen-pop
767 (lambda (ctx)
768 (gen-instruction (list 'pop) 1 0 ctx)))
770 (define gen-return
771 (lambda (ctx)
772 (let ((ss (stack-size (env-local (context-env ctx)))))
773 (gen-instruction (list 'return) ss 0 ctx))))
775 ;-----------------------------------------------------------------------------
777 (define child1
778 (lambda (node)
779 (car (node-children node))))
781 (define child2
782 (lambda (node)
783 (cadr (node-children node))))
785 (define child3
786 (lambda (node)
787 (caddr (node-children node))))
789 (define comp-none
790 (lambda (node ctx)
792 (cond ((or (cst? node)
793 (ref? node)
794 (prc? node))
795 ctx)
797 ((def? node)
798 (let ((var (def-var node)))
799 (if (toplevel-prc-with-non-rest-correct-calls? var)
800 (comp-prc (child1 node) #f ctx)
801 (if (var-needed? var)
802 (let ((ctx2 (comp-push (child1 node) ctx)))
803 (gen-set-global (var-id var) ctx2))
804 (comp-none (child1 node) ctx)))))
806 ((set? node)
807 (let ((var (set-var node)))
808 (if (var-needed? var)
809 (let ((ctx2 (comp-push (child1 node) ctx)))
810 (gen-set-global (var-id var) ctx2))
811 (comp-none (child1 node) ctx))))
813 ((if? node)
814 (let* ((ctx2
815 (context-make-label ctx))
816 (label-then
817 (context-last-label ctx2))
818 (ctx3
819 (context-make-label ctx2))
820 (label-else
821 (context-last-label ctx3))
822 (ctx4
823 (context-make-label ctx3))
824 (label-then-join
825 (context-last-label ctx4))
826 (ctx5
827 (context-make-label ctx4))
828 (label-else-join
829 (context-last-label ctx5))
830 (ctx6
831 (context-make-label ctx5))
832 (label-join
833 (context-last-label ctx6))
834 (ctx7
835 (comp-test (child1 node) label-then label-else ctx6))
836 (ctx8
837 (gen-goto
838 label-else-join
839 (comp-none (child3 node)
840 (context-change-env2
841 (context-add-bb ctx7 label-else)
842 #f))))
843 (ctx9
844 (gen-goto
845 label-then-join
846 (comp-none (child2 node)
847 (context-change-env
848 (context-add-bb ctx8 label-then)
849 (context-env2 ctx7)))))
850 (ctx10
851 (gen-goto
852 label-join
853 (context-add-bb ctx9 label-else-join)))
854 (ctx11
855 (gen-goto
856 label-join
857 (context-add-bb ctx10 label-then-join)))
858 (ctx12
859 (context-add-bb ctx11 label-join)))
860 ctx12))
862 ((call? node)
863 (comp-call node 'none ctx))
865 ((seq? node)
866 (let ((children (node-children node)))
867 (if (null? children)
868 ctx
869 (let loop ((lst children)
870 (ctx ctx))
871 (if (null? (cdr lst))
872 (comp-none (car lst) ctx)
873 (loop (cdr lst)
874 (comp-none (car lst) ctx)))))))
876 (else
877 (compiler-error "unknown expression type" node)))))
879 (define comp-tail
880 (lambda (node ctx)
882 (cond ((or (cst? node)
883 (ref? node)
884 (def? node)
885 (set? node)
886 (prc? node)
887 ; (call? node)
888 )
889 (gen-return (comp-push node ctx)))
891 ((if? node)
892 (let* ((ctx2
893 (context-make-label ctx))
894 (label-then
895 (context-last-label ctx2))
896 (ctx3
897 (context-make-label ctx2))
898 (label-else
899 (context-last-label ctx3))
900 (ctx4
901 (comp-test (child1 node) label-then label-else ctx3))
902 (ctx5
903 (comp-tail (child3 node)
904 (context-change-env2
905 (context-add-bb ctx4 label-else)
906 #f)))
907 (ctx6
908 (comp-tail (child2 node)
909 (context-change-env
910 (context-add-bb ctx5 label-then)
911 (context-env2 ctx4)))))
912 ctx6))
914 ((call? node)
915 (comp-call node 'tail ctx))
917 ((seq? node)
918 (let ((children (node-children node)))
919 (if (null? children)
920 (gen-return (gen-push-unspecified ctx))
921 (let loop ((lst children)
922 (ctx ctx))
923 (if (null? (cdr lst))
924 (comp-tail (car lst) ctx)
925 (loop (cdr lst)
926 (comp-none (car lst) ctx)))))))
928 (else
929 (compiler-error "unknown expression type" node)))))
931 (define comp-push
932 (lambda (node ctx)
934 '(
935 (display "--------------\n")
936 (pp (node->expr node))
937 (pp env)
938 (pp stk)
939 )
941 (cond ((cst? node)
942 (let ((val (cst-val node)))
943 (gen-push-constant val ctx)))
945 ((ref? node)
946 (let ((var (ref-var node)))
947 (if (var-global? var)
948 (if (null? (var-defs var))
949 (compiler-error "undefined variable:" (var-id var))
950 (gen-push-global (var-id var) ctx))
951 (gen-push-local-var (var-id var) ctx))))
953 ((or (def? node)
954 (set? node))
955 (gen-push-unspecified (comp-none node ctx)))
957 ((if? node)
958 (let* ((ctx2
959 (context-make-label ctx))
960 (label-then
961 (context-last-label ctx2))
962 (ctx3
963 (context-make-label ctx2))
964 (label-else
965 (context-last-label ctx3))
966 (ctx4
967 (context-make-label ctx3))
968 (label-then-join
969 (context-last-label ctx4))
970 (ctx5
971 (context-make-label ctx4))
972 (label-else-join
973 (context-last-label ctx5))
974 (ctx6
975 (context-make-label ctx5))
976 (label-join
977 (context-last-label ctx6))
978 (ctx7
979 (comp-test (child1 node) label-then label-else ctx6))
980 (ctx8
981 (gen-goto
982 label-else-join
983 (comp-push (child3 node)
984 (context-change-env2
985 (context-add-bb ctx7 label-else)
986 #f))))
987 (ctx9
988 (gen-goto
989 label-then-join
990 (comp-push (child2 node)
991 (context-change-env
992 (context-add-bb ctx8 label-then)
993 (context-env2 ctx7)))))
994 (ctx10
995 (gen-goto
996 label-join
997 (context-add-bb ctx9 label-else-join)))
998 (ctx11
999 (gen-goto
1000 label-join
1001 (context-add-bb ctx10 label-then-join)))
1002 (ctx12
1003 (context-add-bb ctx11 label-join)))
1004 ctx12))
1006 ((prc? node)
1007 (comp-prc node #t ctx))
1009 ((call? node)
1010 (comp-call node 'push ctx))
1012 ((seq? node)
1013 (let ((children (node-children node)))
1014 (if (null? children)
1015 (gen-push-unspecified ctx)
1016 (let loop ((lst children)
1017 (ctx ctx))
1018 (if (null? (cdr lst))
1019 (comp-push (car lst) ctx)
1020 (loop (cdr lst)
1021 (comp-none (car lst) ctx)))))))
1023 (else
1024 (compiler-error "unknown expression type" node)))))
1026 (define (build-closure label-entry vars ctx)
1028 (define (build vars ctx)
1029 (if (null? vars)
1030 (gen-push-constant '() ctx)
1031 (gen-prim '#%cons
1032 2
1033 #f
1034 (build (cdr vars)
1035 (gen-push-local-var (car vars) ctx)))))
1037 (if (null? vars)
1038 (gen-closure label-entry
1039 ;; (gen-push-constant '() ;; TODO FOOBAR this is probably where we have to change the size of the pointer to 12 bits, instead of '() #f (#x0200), it should be (#x0020), but is #x20 a constant ? if not, it should be gen push something, actually, looks like it's a fixnum, 24 to be exact
1040 ;; (gen-push-constant #f ctx))
1041 (gen-push-constant #f (gen-push-constant 24 ctx))
1042 ;; TODO ugly hack, probably doesn't even work FOOBAR
1043 )
1044 (gen-closure label-entry ;; TODO can a similar hack be done to extend pointer size ? similar to above, that is, or is it even necessary since build calls cons ? maybe for the original empty list ?
1045 (build (cdr vars)
1046 (gen-push-local-var (car vars) ctx)))))
1048 (define comp-prc
1049 (lambda (node closure? ctx)
1050 (let* ((ctx2
1051 (context-make-label ctx))
1052 (label-entry
1053 (context-last-label ctx2))
1054 (ctx3
1055 (context-make-label ctx2))
1056 (label-continue
1057 (context-last-label ctx3))
1058 (body-env
1059 (prc->env node))
1060 (ctx4
1061 (if closure?
1062 (build-closure label-entry (env-closed body-env) ctx3)
1063 ctx3))
1064 (ctx5
1065 (gen-goto label-continue ctx4))
1066 (ctx6
1067 (gen-entry (length (prc-params node))
1068 (prc-rest? node)
1069 (context-add-bb (context-change-env ctx5
1070 body-env)
1071 label-entry)))
1072 (ctx7
1073 (comp-tail (child1 node) ctx6)))
1074 (prc-entry-label-set! node label-entry)
1075 (context-add-bb (context-change-env ctx7 (context-env ctx5))
1076 label-continue))))
1078 (define comp-call
1079 (lambda (node reason ctx)
1080 (let* ((op (child1 node))
1081 (args (cdr (node-children node)))
1082 (nargs (length args)))
1083 (let loop ((lst args)
1084 (ctx ctx))
1085 (if (pair? lst)
1087 (let ((arg (car lst)))
1088 (loop (cdr lst)
1089 (comp-push arg ctx)))
1091 (cond ((and (ref? op)
1092 (var-primitive (ref-var op)))
1093 (let* ((var (ref-var op))
1094 (id (var-id var))
1095 (primitive (var-primitive var))
1096 (prim-nargs (primitive-nargs primitive)))
1098 (define use-result
1099 (lambda (ctx2)
1100 (cond ((eq? reason 'tail)
1101 (gen-return
1102 (if (primitive-unspecified-result? primitive)
1103 (gen-push-unspecified ctx2)
1104 ctx2)))
1105 ((eq? reason 'push)
1106 (if (primitive-unspecified-result? primitive)
1107 (gen-push-unspecified ctx2)
1108 ctx2))
1109 (else
1110 (if (primitive-unspecified-result? primitive)
1111 ctx2
1112 (gen-pop ctx2))))))
1114 (use-result
1115 (if (primitive-inliner primitive)
1116 ((primitive-inliner primitive) ctx)
1117 (if (not (= nargs prim-nargs))
1118 (compiler-error "primitive called with wrong number of arguments" id)
1119 (gen-prim
1120 id
1121 prim-nargs
1122 (primitive-unspecified-result? primitive)
1123 ctx))))))
1126 ((and (ref? op)
1127 (toplevel-prc-with-non-rest-correct-calls? (ref-var op)))
1128 =>
1129 (lambda (prc)
1130 (cond ((eq? reason 'tail)
1131 (gen-jump-toplevel nargs prc ctx))
1132 ((eq? reason 'push)
1133 (gen-call-toplevel nargs prc ctx))
1134 (else
1135 (gen-pop (gen-call-toplevel nargs prc ctx))))))
1137 (else
1138 (let ((ctx2 (comp-push op ctx)))
1139 (cond ((eq? reason 'tail)
1140 (gen-jump nargs ctx2))
1141 ((eq? reason 'push)
1142 (gen-call nargs ctx2))
1143 (else
1144 (gen-pop (gen-call nargs ctx2))))))))))))
1146 (define comp-test
1147 (lambda (node label-true label-false ctx)
1148 (cond ((cst? node)
1149 (let ((ctx2
1150 (gen-goto
1151 (let ((val (cst-val node)))
1152 (if val
1153 label-true
1154 label-false))
1155 ctx)))
1156 (context-change-env2 ctx2 (context-env ctx2))))
1158 ((or (ref? node)
1159 (def? node)
1160 (set? node)
1161 (if? node)
1162 (call? node)
1163 (seq? node))
1164 (let* ((ctx2
1165 (comp-push node ctx))
1166 (ctx3
1167 (gen-goto-if-false label-false label-true ctx2)))
1168 (context-change-env2 ctx3 (context-env ctx3))))
1170 ((prc? node)
1171 (let ((ctx2
1172 (gen-goto label-true ctx)))
1173 (context-change-env2 ctx2 (context-env ctx2))))
1175 (else
1176 (compiler-error "unknown expression type" node)))))
1178 ;-----------------------------------------------------------------------------
1180 (define toplevel-prc?
1181 (lambda (var)
1182 (and (not (mutable-var? var))
1183 (let ((d (var-defs var)))
1184 (and (pair? d)
1185 (null? (cdr d))
1186 (let ((val (child1 (car d))))
1187 (and (prc? val)
1188 val)))))))
1190 (define toplevel-prc-with-non-rest-correct-calls?
1191 (lambda (var)
1192 (let ((prc (toplevel-prc? var)))
1193 (and prc
1194 (not (prc-rest? prc))
1195 (every (lambda (r)
1196 (let ((parent (node-parent r)))
1197 (and (call? parent)
1198 (eq? (child1 parent) r)
1199 (= (length (prc-params prc))
1200 (- (length (node-children parent)) 1)))))
1201 (var-refs var))
1202 prc))))
1204 (define mutable-var? ;; TODO use it to put immutable globals in rom
1205 (lambda (var)
1206 (not (null? (var-sets var)))))
1208 (define global-fv
1209 (lambda (node)
1210 (list->varset
1211 (keep var-global?
1212 (varset->list (fv node))))))
1214 (define non-global-fv
1215 (lambda (node)
1216 (list->varset
1217 (keep (lambda (x) (not (var-global? x)))
1218 (varset->list (fv node))))))
1220 (define fv
1221 (lambda (node)
1222 (cond ((cst? node)
1223 (varset-empty))
1224 ((ref? node)
1225 (let ((var (ref-var node)))
1226 (varset-singleton var)))
1227 ((def? node)
1228 (let ((var (def-var node))
1229 (val (child1 node)))
1230 (varset-union
1231 (varset-singleton var)
1232 (fv val))))
1233 ((set? node)
1234 (let ((var (set-var node))
1235 (val (child1 node)))
1236 (varset-union
1237 (varset-singleton var)
1238 (fv val))))
1239 ((if? node)
1240 (let ((a (list-ref (node-children node) 0))
1241 (b (list-ref (node-children node) 1))
1242 (c (list-ref (node-children node) 2)))
1243 (varset-union-multi (list (fv a) (fv b) (fv c)))))
1244 ((prc? node)
1245 (let ((body (list-ref (node-children node) 0)))
1246 (varset-difference
1247 (fv body)
1248 (build-params-varset (prc-params node)))))
1249 ((call? node)
1250 (varset-union-multi (map fv (node-children node))))
1251 ((seq? node)
1252 (varset-union-multi (map fv (node-children node))))
1253 (else
1254 (compiler-error "unknown expression type" node)))))
1256 (define build-params-varset
1257 (lambda (params)
1258 (list->varset params)))
1260 (define mark-needed-global-vars!
1261 (lambda (global-env node)
1263 (define readyq
1264 (env-lookup global-env '#%readyq))
1266 (define mark-var!
1267 (lambda (var)
1268 (if (and (var-global? var)
1269 (not (var-needed? var)))
1270 (begin
1271 (var-needed?-set! var #t)
1272 (for-each
1273 (lambda (def)
1274 (let ((val (child1 def)))
1275 (if (side-effect-less? val)
1276 (mark! val))))
1277 (var-defs var))
1278 (if (eq? var readyq)
1279 (begin
1280 (mark-var!
1281 (env-lookup global-env '#%start-first-process))
1282 (mark-var!
1283 (env-lookup global-env '#%exit))))))))
1285 (define side-effect-less?
1286 (lambda (node)
1287 (or (cst? node)
1288 (ref? node)
1289 (prc? node))))
1291 (define mark!
1292 (lambda (node)
1293 (cond ((cst? node))
1294 ((ref? node)
1295 (let ((var (ref-var node)))
1296 (mark-var! var)))
1297 ((def? node)
1298 (let ((var (def-var node))
1299 (val (child1 node)))
1300 (if (not (side-effect-less? val))
1301 (mark! val))))
1302 ((set? node)
1303 (let ((var (set-var node))
1304 (val (child1 node)))
1305 (mark! val)))
1306 ((if? node)
1307 (let ((a (list-ref (node-children node) 0))
1308 (b (list-ref (node-children node) 1))
1309 (c (list-ref (node-children node) 2)))
1310 (mark! a)
1311 (mark! b)
1312 (mark! c)))
1313 ((prc? node)
1314 (let ((body (list-ref (node-children node) 0)))
1315 (mark! body)))
1316 ((call? node)
1317 (for-each mark! (node-children node)))
1318 ((seq? node)
1319 (for-each mark! (node-children node)))
1320 (else
1321 (compiler-error "unknown expression type" node)))))
1323 (mark! node)
1324 ))
1326 ;-----------------------------------------------------------------------------
1328 ; Variable sets
1330 (define (varset-empty) ; return the empty set
1331 '())
1333 (define (varset-singleton x) ; create a set containing only 'x'
1334 (list x))
1336 (define (list->varset lst) ; convert list to set
1337 lst)
1339 (define (varset->list set) ; convert set to list
1340 set)
1342 (define (varset-size set) ; return cardinality of set
1343 (list-length set))
1345 (define (varset-empty? set) ; is 'x' the empty set?
1346 (null? set))
1348 (define (varset-member? x set) ; is 'x' a member of the 'set'?
1349 (and (not (null? set))
1350 (or (eq? x (car set))
1351 (varset-member? x (cdr set)))))
1353 (define (varset-adjoin set x) ; add the element 'x' to the 'set'
1354 (if (varset-member? x set) set (cons x set)))
1356 (define (varset-remove set x) ; remove the element 'x' from 'set'
1357 (cond ((null? set)
1358 '())
1359 ((eq? (car set) x)
1360 (cdr set))
1361 (else
1362 (cons (car set) (varset-remove (cdr set) x)))))
1364 (define (varset-equal? s1 s2) ; are 's1' and 's2' equal sets?
1365 (and (varset-subset? s1 s2)
1366 (varset-subset? s2 s1)))
1368 (define (varset-subset? s1 s2) ; is 's1' a subset of 's2'?
1369 (cond ((null? s1)
1370 #t)
1371 ((varset-member? (car s1) s2)
1372 (varset-subset? (cdr s1) s2))
1373 (else
1374 #f)))
1376 (define (varset-difference set1 set2) ; return difference of sets
1377 (cond ((null? set1)
1378 '())
1379 ((varset-member? (car set1) set2)
1380 (varset-difference (cdr set1) set2))
1381 (else
1382 (cons (car set1) (varset-difference (cdr set1) set2)))))
1384 (define (varset-union set1 set2) ; return union of sets
1385 (define (union s1 s2)
1386 (cond ((null? s1)
1387 s2)
1388 ((varset-member? (car s1) s2)
1389 (union (cdr s1) s2))
1390 (else
1391 (cons (car s1) (union (cdr s1) s2)))))
1392 (if (varset-smaller? set1 set2)
1393 (union set1 set2)
1394 (union set2 set1)))
1396 (define (varset-intersection set1 set2) ; return intersection of sets
1397 (define (intersection s1 s2)
1398 (cond ((null? s1)
1399 '())
1400 ((varset-member? (car s1) s2)
1401 (cons (car s1) (intersection (cdr s1) s2)))
1402 (else
1403 (intersection (cdr s1) s2))))
1404 (if (varset-smaller? set1 set2)
1405 (intersection set1 set2)
1406 (intersection set2 set1)))
1408 (define (varset-intersects? set1 set2) ; do sets 'set1' and 'set2' intersect?
1409 (not (varset-empty? (varset-intersection set1 set2))))
1411 (define (varset-smaller? set1 set2)
1412 (if (null? set1)
1413 (not (null? set2))
1414 (if (null? set2)
1415 #f
1416 (varset-smaller? (cdr set1) (cdr set2)))))
1418 (define (varset-union-multi sets)
1419 (if (null? sets)
1420 (varset-empty)
1421 (n-ary varset-union (car sets) (cdr sets))))
1423 (define (n-ary function first rest)
1424 (if (null? rest)
1425 first
1426 (n-ary function (function first (car rest)) (cdr rest))))
1428 ;------------------------------------------------------------------------------
1430 (define code->vector
1431 (lambda (code)
1432 (let ((v (make-vector (+ (code-last-label code) 1))))
1433 (for-each
1434 (lambda (bb)
1435 (vector-set! v (bb-label bb) bb))
1436 (code-rev-bbs code))
1437 v)))
1439 (define bbs->ref-counts
1440 (lambda (bbs)
1441 (let ((ref-counts (make-vector (vector-length bbs) 0)))
1443 (define visit
1444 (lambda (label)
1445 (let ((ref-count (vector-ref ref-counts label)))
1446 (vector-set! ref-counts label (+ ref-count 1))
1447 (if (= ref-count 0)
1448 (let* ((bb (vector-ref bbs label))
1449 (rev-instrs (bb-rev-instrs bb)))
1450 (for-each
1451 (lambda (instr)
1452 (let ((opcode (car instr)))
1453 (cond ((eq? opcode 'goto)
1454 (visit (cadr instr)))
1455 ((eq? opcode 'goto-if-false)
1456 (visit (cadr instr))
1457 (visit (caddr instr)))
1458 ((or (eq? opcode 'closure)
1459 (eq? opcode 'call-toplevel)
1460 (eq? opcode 'jump-toplevel))
1461 (visit (cadr instr))))))
1462 rev-instrs))))))
1464 (visit 0)
1466 ref-counts)))
1468 (define resolve-toplevel-labels!
1469 (lambda (bbs)
1470 (let loop ((i 0))
1471 (if (< i (vector-length bbs))
1472 (let* ((bb (vector-ref bbs i))
1473 (rev-instrs (bb-rev-instrs bb)))
1474 (bb-rev-instrs-set!
1475 bb
1476 (map (lambda (instr)
1477 (let ((opcode (car instr)))
1478 (cond ((eq? opcode 'call-toplevel)
1479 (list opcode
1480 (prc-entry-label (cadr instr))))
1481 ((eq? opcode 'jump-toplevel)
1482 (list opcode
1483 (prc-entry-label (cadr instr))))
1484 (else
1485 instr))))
1486 rev-instrs))
1487 (loop (+ i 1)))))))
1489 (define tighten-jump-cascades!
1490 (lambda (bbs)
1491 (let ((ref-counts (bbs->ref-counts bbs)))
1493 (define resolve
1494 (lambda (label)
1495 (let* ((bb (vector-ref bbs label))
1496 (rev-instrs (bb-rev-instrs bb)))
1497 (and (or (null? (cdr rev-instrs))
1498 (= (vector-ref ref-counts label) 1))
1499 rev-instrs))))
1501 (let loop1 ()
1502 (let loop2 ((i 0)
1503 (changed? #f))
1504 (if (< i (vector-length bbs))
1505 (if (> (vector-ref ref-counts i) 0)
1506 (let* ((bb (vector-ref bbs i))
1507 (rev-instrs (bb-rev-instrs bb))
1508 (jump (car rev-instrs))
1509 (opcode (car jump)))
1510 (cond ((eq? opcode 'goto)
1511 (let* ((label (cadr jump))
1512 (jump-replacement (resolve label)))
1513 (if jump-replacement
1514 (begin
1515 (vector-set!
1516 bbs
1517 i
1518 (make-bb (bb-label bb)
1519 (append jump-replacement
1520 (cdr rev-instrs))))
1521 (loop2 (+ i 1)
1522 #t))
1523 (loop2 (+ i 1)
1524 changed?))))
1525 ((eq? opcode 'goto-if-false)
1526 (let* ((label-then (cadr jump))
1527 (label-else (caddr jump))
1528 (jump-then-replacement (resolve label-then))
1529 (jump-else-replacement (resolve label-else)))
1530 (if (and jump-then-replacement
1531 (null? (cdr jump-then-replacement))
1532 jump-else-replacement
1533 (null? (cdr jump-else-replacement))
1534 (or (eq? (caar jump-then-replacement) 'goto)
1535 (eq? (caar jump-else-replacement) 'goto)))
1536 (begin
1537 (vector-set!
1538 bbs
1539 i
1540 (make-bb (bb-label bb)
1541 (cons (list 'goto-if-false
1542 (if (eq? (caar jump-then-replacement) 'goto)
1543 (cadar jump-then-replacement)
1544 label-then)
1545 (if (eq? (caar jump-else-replacement) 'goto)
1546 (cadar jump-else-replacement)
1547 label-else))
1548 (cdr rev-instrs))))
1549 (loop2 (+ i 1)
1550 #t))
1551 (loop2 (+ i 1)
1552 changed?))))
1553 (else
1554 (loop2 (+ i 1)
1555 changed?))))
1556 (loop2 (+ i 1)
1557 changed?))
1558 (if changed?
1559 (loop1))))))))
1561 (define remove-useless-bbs!
1562 (lambda (bbs)
1563 (let ((ref-counts (bbs->ref-counts bbs)))
1564 (let loop1 ((label 0) (new-label 0))
1565 (if (< label (vector-length bbs))
1566 (if (> (vector-ref ref-counts label) 0)
1567 (let ((bb (vector-ref bbs label)))
1568 (vector-set!
1569 bbs
1570 label
1571 (make-bb new-label (bb-rev-instrs bb)))
1572 (loop1 (+ label 1) (+ new-label 1)))
1573 (loop1 (+ label 1) new-label))
1574 (renumber-labels bbs ref-counts new-label))))))
1576 (define renumber-labels
1577 (lambda (bbs ref-counts n)
1578 (let ((new-bbs (make-vector n)))
1579 (let loop2 ((label 0))
1580 (if (< label (vector-length bbs))
1581 (if (> (vector-ref ref-counts label) 0)
1582 (let* ((bb (vector-ref bbs label))
1583 (new-label (bb-label bb))
1584 (rev-instrs (bb-rev-instrs bb)))
1586 (define fix
1587 (lambda (instr)
1589 (define new-label
1590 (lambda (label)
1591 (bb-label (vector-ref bbs label))))
1593 (let ((opcode (car instr)))
1594 (cond ((eq? opcode 'closure)
1595 (list 'closure
1596 (new-label (cadr instr))))
1597 ((eq? opcode 'call-toplevel)
1598 (list 'call-toplevel
1599 (new-label (cadr instr))))
1600 ((eq? opcode 'jump-toplevel)
1601 (list 'jump-toplevel
1602 (new-label (cadr instr))))
1603 ((eq? opcode 'goto)
1604 (list 'goto
1605 (new-label (cadr instr))))
1606 ((eq? opcode 'goto-if-false)
1607 (list 'goto-if-false
1608 (new-label (cadr instr))
1609 (new-label (caddr instr))))
1610 (else
1611 instr)))))
1613 (vector-set!
1614 new-bbs
1615 new-label
1616 (make-bb new-label (map fix rev-instrs)))
1617 (loop2 (+ label 1)))
1618 (loop2 (+ label 1)))
1619 new-bbs)))))
1621 (define reorder!
1622 (lambda (bbs)
1623 (let* ((done (make-vector (vector-length bbs) #f)))
1625 (define unscheduled?
1626 (lambda (label)
1627 (not (vector-ref done label))))
1629 (define label-refs
1630 (lambda (instrs todo)
1631 (if (pair? instrs)
1632 (let* ((instr (car instrs))
1633 (opcode (car instr)))
1634 (cond ((or (eq? opcode 'closure)
1635 (eq? opcode 'call-toplevel)
1636 (eq? opcode 'jump-toplevel))
1637 (label-refs (cdr instrs) (cons (cadr instr) todo)))
1638 (else
1639 (label-refs (cdr instrs) todo))))
1640 todo)))
1642 (define schedule-here
1643 (lambda (label new-label todo cont)
1644 (let* ((bb (vector-ref bbs label))
1645 (rev-instrs (bb-rev-instrs bb))
1646 (jump (car rev-instrs))
1647 (opcode (car jump))
1648 (new-todo (label-refs rev-instrs todo)))
1649 (vector-set! bbs label (make-bb new-label rev-instrs))
1650 (vector-set! done label #t)
1651 (cond ((eq? opcode 'goto)
1652 (let ((label (cadr jump)))
1653 (if (unscheduled? label)
1654 (schedule-here label
1655 (+ new-label 1)
1656 new-todo
1657 cont)
1658 (cont (+ new-label 1)
1659 new-todo))))
1660 ((eq? opcode 'goto-if-false)
1661 (let ((label-then (cadr jump))
1662 (label-else (caddr jump)))
1663 (cond ((unscheduled? label-else)
1664 (schedule-here label-else
1665 (+ new-label 1)
1666 (cons label-then new-todo)
1667 cont))
1668 ((unscheduled? label-then)
1669 (schedule-here label-then
1670 (+ new-label 1)
1671 new-todo
1672 cont))
1673 (else
1674 (cont (+ new-label 1)
1675 new-todo)))))
1676 (else
1677 (cont (+ new-label 1)
1678 new-todo))))))
1680 (define schedule-somewhere
1681 (lambda (label new-label todo cont)
1682 (schedule-here label new-label todo cont)))
1684 (define schedule-todo
1685 (lambda (new-label todo)
1686 (if (pair? todo)
1687 (let ((label (car todo)))
1688 (if (unscheduled? label)
1689 (schedule-somewhere label
1690 new-label
1691 (cdr todo)
1692 schedule-todo)
1693 (schedule-todo new-label
1694 (cdr todo)))))))
1697 (schedule-here 0 0 '() schedule-todo)
1699 (renumber-labels bbs
1700 (make-vector (vector-length bbs) 1)
1701 (vector-length bbs)))))
1703 (define linearize
1704 (lambda (bbs)
1705 (let loop ((label (- (vector-length bbs) 1))
1706 (lst '()))
1707 (if (>= label 0)
1708 (let* ((bb (vector-ref bbs label))
1709 (rev-instrs (bb-rev-instrs bb))
1710 (jump (car rev-instrs))
1711 (opcode (car jump)))
1712 (loop (- label 1)
1713 (append
1714 (list label)
1715 (reverse
1716 (cond ((eq? opcode 'goto)
1717 (if (= (cadr jump) (+ label 1))
1718 (cdr rev-instrs)
1719 rev-instrs))
1720 ((eq? opcode 'goto-if-false)
1721 (cond ((= (caddr jump) (+ label 1))
1722 (cons (list 'goto-if-false (cadr jump))
1723 (cdr rev-instrs)))
1724 ((= (cadr jump) (+ label 1))
1725 (cons (list 'goto-if-not-false (caddr jump))
1726 (cdr rev-instrs)))
1727 (else
1728 (cons (list 'goto (caddr jump))
1729 (cons (list 'goto-if-false (cadr jump))
1730 (cdr rev-instrs))))))
1731 (else
1732 rev-instrs)))
1733 lst)))
1734 lst))))
1736 (define optimize-code
1737 (lambda (code)
1738 (let ((bbs (code->vector code)))
1739 (resolve-toplevel-labels! bbs)
1740 (tighten-jump-cascades! bbs)
1741 (let ((bbs (remove-useless-bbs! bbs)))
1742 (reorder! bbs)))))
1744 (define expand-loads ;; ADDED
1745 (lambda (exprs)
1746 (map (lambda (e)
1747 (if (eq? (car e) 'load)
1748 (cons 'begin
1749 (expand-loads (with-input-from-file (cadr e) read-all)))
1750 e))
1751 exprs)))
1753 (define parse-file
1754 (lambda (filename)
1755 (let* ((library
1756 (with-input-from-file "library.scm" read-all))
1757 (toplevel-exprs
1758 (expand-loads (append library ;; ADDED (didn't have expand-loads)
1759 (with-input-from-file filename read-all))))
1760 (global-env
1761 (make-global-env))
1762 (parsed-prog
1763 (parse-top (cons 'begin toplevel-exprs) global-env)))
1765 (for-each
1766 (lambda (node)
1767 (mark-needed-global-vars! global-env node))
1768 parsed-prog)
1770 (extract-parts
1771 parsed-prog
1772 (lambda (defs after-defs)
1774 (define make-seq-preparsed
1775 (lambda (exprs)
1776 (let ((r (make-seq #f exprs)))
1777 (for-each (lambda (x) (node-parent-set! x r)) exprs)
1778 r)))
1780 (define make-call-preparsed
1781 (lambda (exprs)
1782 (let ((r (make-call #f exprs)))
1783 (for-each (lambda (x) (node-parent-set! x r)) exprs)
1784 r)))
1786 (if (var-needed?
1787 (env-lookup global-env '#%readyq))
1788 (make-seq-preparsed
1789 (list (make-seq-preparsed defs)
1790 (make-call-preparsed
1791 (list (parse 'value '#%start-first-process global-env)
1792 (let* ((pattern
1793 '())
1794 (ids
1795 (extract-ids pattern))
1796 (r
1797 (make-prc #f '() #f (has-rest-param? pattern) #f))
1798 (new-env
1799 (env-extend global-env ids r))
1800 (body
1801 (make-seq-preparsed after-defs)))
1802 (prc-params-set!
1803 r
1804 (map (lambda (id) (env-lookup new-env id))
1805 ids))
1806 (node-children-set! r (list body))
1807 (node-parent-set! body r)
1808 r)))
1809 (parse 'value
1810 '(#%exit)
1811 global-env)))
1812 (make-seq-preparsed
1813 (append defs
1814 after-defs
1815 (list (parse 'value
1816 '(#%halt)
1817 global-env))))))))))
1819 (define extract-parts
1820 (lambda (lst cont)
1821 (if (or (null? lst)
1822 (not (def? (car lst))))
1823 (cont '() lst)
1824 (extract-parts
1825 (cdr lst)
1826 (lambda (d ad)
1827 (cont (cons (car lst) d) ad))))))
1829 ;------------------------------------------------------------------------------
1831 ;(include "asm.scm")
1833 ;;; File: "asm.scm"
1834 ;;;
1835 ;;; This module implements the generic assembler.
1837 ;(##declare (standard-bindings) (fixnum) (block))
1839 (define compiler-internal-error error)
1841 ;; (asm-begin! start-pos big-endian?) initializes the assembler and
1842 ;; starts a new empty code stream at address "start-pos". It must be
1843 ;; called every time a new code stream is to be built. The argument
1844 ;; "big-endian?" indicates the byte ordering to use for 16, 32 and 64
1845 ;; bit values. After a call to "asm-begin!" the code stream is built
1846 ;; by calling the following procedures:
1847 ;;
1848 ;; asm-8 to add an 8 bit integer to the code stream
1849 ;; asm-16 to add a 16 bit integer to the code stream
1850 ;; asm-32 to add a 32 bit integer to the code stream
1851 ;; asm-64 to add a 64 bit integer to the code stream
1852 ;; asm-float64 to add a 64 bit IEEE float to the code stream
1853 ;; asm-string to add a null terminated string to the code stream
1854 ;; asm-label to set a label to the current position in the code stream
1855 ;; asm-align to add enough zero bytes to force alignment
1856 ;; asm-origin to add enough zero bytes to move to a particular address
1857 ;; asm-at-assembly to defer code production to assembly time
1858 ;; asm-listing to add textual information to the listing
1860 (define (asm-begin! start-pos big-endian?)
1861 (set! asm-start-pos start-pos)
1862 (set! asm-big-endian? big-endian?)
1863 (set! asm-code-stream (asm-make-stream))
1864 #f)
1866 ;; (asm-end!) must be called to finalize the assembler.
1868 (define (asm-end!)
1869 (set! asm-code-stream #f)
1870 #f)
1872 ;; (asm-8 n) adds an 8 bit signed or unsigned integer to the code stream.
1874 (define (asm-8 n)
1875 (asm-code-extend (asm-bits-0-to-7 n)))
1877 ;; (asm-16 n) adds a 16 bit signed or unsigned integer to the code stream.
1879 (define (asm-16 n)
1880 (if asm-big-endian?
1881 (begin (asm-8 (asm-bits-8-and-up n)) (asm-8 n))
1882 (begin (asm-8 n) (asm-8 (asm-bits-8-and-up n)))))
1884 ;; (asm-32 n) adds a 32 bit signed or unsigned integer to the code stream.
1886 (define (asm-32 n)
1887 (if asm-big-endian?
1888 (begin (asm-16 (asm-bits-16-and-up n)) (asm-16 n))
1889 (begin (asm-16 n) (asm-16 (asm-bits-16-and-up n)))))
1891 ;; (asm-64 n) adds a 64 bit signed or unsigned integer to the code stream.
1893 (define (asm-64 n)
1894 (if asm-big-endian?
1895 (begin (asm-32 (asm-bits-32-and-up n)) (asm-32 n))
1896 (begin (asm-32 n) (asm-32 (asm-bits-32-and-up n)))))
1898 ;; (asm-float64 n) adds a 64 bit IEEE floating point number to the code stream.
1900 (define (asm-float64 n)
1901 (asm-64 (asm-float->bits n)))
1903 ;; (asm-string str) adds a null terminated string to the code stream.
1905 (define (asm-string str)
1906 (let ((len (string-length str)))
1907 (let loop ((i 0))
1908 (if (< i len)
1909 (begin
1910 (asm-8 (char->integer (string-ref str i)))
1911 (loop (+ i 1)))
1912 (asm-8 0)))))
1914 ;; (asm-make-label id) creates a new label object. A label can
1915 ;; be queried with "asm-label-pos" to obtain the label's position
1916 ;; relative to the start of the code stream (i.e. "start-pos").
1917 ;; The argument "id" gives a name to the label (not necessarily
1918 ;; unique) and is only needed for debugging purposes.
1920 (define (asm-make-label id)
1921 (vector 'LABEL #f id))
1923 ;; (asm-label label-obj) sets the label to the current position in the
1924 ;; code stream.
1926 (define (asm-label label-obj)
1927 (if (vector-ref label-obj 1)
1928 (compiler-internal-error
1929 "asm-label, label multiply defined" (asm-label-id label-obj))
1930 (begin
1931 (vector-set! label-obj 1 0)
1932 (asm-code-extend label-obj))))
1934 ;; (asm-label-id label-obj) returns the identifier of the label object.
1936 (define (asm-label-id label-obj)
1937 (vector-ref label-obj 2))
1939 ;; (asm-label-pos label-obj) returns the position of the label
1940 ;; relative to the start of the code stream (i.e. "start-pos").
1941 ;; This procedure can only be called at assembly time (i.e.
1942 ;; within the call to "asm-assemble") or after assembly time
1943 ;; for labels declared prior to assembly time with "asm-label".
1944 ;; A label declared at assembly time can only be queried after
1945 ;; assembly time. Moreover, at assembly time the position of a
1946 ;; label may vary from one call to the next due to the actions
1947 ;; of the assembler.
1949 (define (asm-label-pos label-obj)
1950 (let ((pos (vector-ref label-obj 1)))
1951 (if pos
1952 pos
1953 (compiler-internal-error
1954 "asm-label-pos, undefined label" (asm-label-id label-obj)))))
1956 ;; (asm-align multiple offset) adds enough zero bytes to the code
1957 ;; stream to force alignment to the next address congruent to
1958 ;; "offset" modulo "multiple".
1960 (define (asm-align multiple offset)
1961 (asm-at-assembly
1962 (lambda (self)
1963 (modulo (- multiple (- self offset)) multiple))
1964 (lambda (self)
1965 (let loop ((n (modulo (- multiple (- self offset)) multiple)))
1966 (if (> n 0)
1967 (begin
1968 (asm-8 0)
1969 (loop (- n 1))))))))
1971 ;; (asm-origin address) adds enough zero bytes to the code stream to move
1972 ;; to the address "address".
1974 (define (asm-origin address)
1975 (asm-at-assembly
1976 (lambda (self)
1977 (- address self))
1978 (lambda (self)
1979 (let ((len (- address self)))
1980 (if (< len 0)
1981 (compiler-internal-error "asm-origin, can't move back")
1982 (let loop ((n len))
1983 (if (> n 0)
1984 (begin
1985 (asm-8 0)
1986 (loop (- n 1))))))))))
1988 ;; (asm-at-assembly . procs) makes it possible to defer code
1989 ;; production to assembly time. A useful application is to generate
1990 ;; position dependent and span dependent code sequences. This
1991 ;; procedure must be passed an even number of procedures. All odd
1992 ;; indexed procedures (including the first procedure) are called "check"
1993 ;; procedures. The even indexed procedures are the "production"
1994 ;; procedures which, when called, produce a particular code sequence.
1995 ;; A check procedure decides if, given the current state of assembly
1996 ;; (in particular the current positioning of the labels), the code
1997 ;; produced by the corresponding production procedure is valid.
1998 ;; If the code is not valid, the check procedure must return #f.
1999 ;; If the code is valid, the check procedure must return the length
2000 ;; of the code sequence in bytes. The assembler will try each check
2001 ;; procedure in order until it finds one that does not return #f
2002 ;; (the last check procedure must never return #f). For convenience,
2003 ;; the current position in the code sequence is passed as the single
2004 ;; argument of check and production procedures.
2005 ;;
2006 ;; Here is a sample call of "asm-at-assembly" to produce the
2007 ;; shortest branch instruction to branch to label "x" for a
2008 ;; hypothetical processor:
2009 ;;
2010 ;; (asm-at-assembly
2011 ;;
2012 ;; (lambda (self) ; first check procedure
2013 ;; (let ((dist (- (asm-label-pos x) self)))
2014 ;; (if (and (>= dist -128) (<= dist 127)) ; short branch possible?
2015 ;; 2
2016 ;; #f)))
2017 ;;
2018 ;; (lambda (self) ; first production procedure
2019 ;; (asm-8 #x34) ; branch opcode for 8 bit displacement
2020 ;; (asm-8 (- (asm-label-pos x) self)))
2021 ;;
2022 ;; (lambda (self) 5) ; second check procedure
2023 ;;
2024 ;; (lambda (self) ; second production procedure
2025 ;; (asm-8 #x35) ; branch opcode for 32 bit displacement
2026 ;; (asm-32 (- (asm-label-pos x) self))))
2028 (define (asm-at-assembly . procs)
2029 (asm-code-extend (vector 'DEFERRED procs)))
2031 ;; (asm-listing text) adds text to the right side of the listing.
2032 ;; The atoms in "text" will be output using "display" (lists are
2033 ;; traversed recursively). The listing is generated by calling
2034 ;; "asm-display-listing".
2036 (define (asm-listing text)
2037 (asm-code-extend (vector 'LISTING text)))
2039 ;; (asm-assemble) assembles the code stream. After assembly, the
2040 ;; label objects will be set to their final position and the
2041 ;; alignment bytes and the deferred code will have been produced. It
2042 ;; is possible to extend the code stream after assembly. However, if
2043 ;; any of the procedures "asm-label", "asm-align", and
2044 ;; "asm-at-assembly" are called, the code stream will have to be
2045 ;; assembled once more.
2047 (define (asm-assemble)
2048 (let ((fixup-lst (asm-pass1)))
2050 (let loop1 ()
2051 (let loop2 ((lst fixup-lst)
2052 (changed? #f)
2053 (pos asm-start-pos))
2054 (if (null? lst)
2055 (if changed? (loop1))
2056 (let* ((fixup (car lst))
2057 (pos (+ pos (car fixup)))
2058 (curr (cdr fixup))
2059 (x (car curr)))
2060 (if (eq? (vector-ref x 0) 'LABEL)
2061 ; LABEL
2062 (if (= (vector-ref x 1) pos)
2063 (loop2 (cdr lst) changed? pos)
2064 (begin
2065 (vector-set! x 1 pos)
2066 (loop2 (cdr lst) #t pos)))
2067 ; DEFERRED
2068 (let loop3 ()
2069 (let ((n ((car (vector-ref x 1)) pos)))
2070 (if n
2071 (loop2 (cdr lst) changed? (+ pos n))
2072 (begin
2073 (vector-set! x 1 (cddr (vector-ref x 1)))
2074 (loop3))))))))))
2076 (let loop4 ((prev asm-code-stream)
2077 (curr (cdr asm-code-stream))
2078 (pos asm-start-pos))
2079 (if (null? curr)
2080 (set-car! asm-code-stream prev)
2081 (let ((x (car curr))
2082 (next (cdr curr)))
2083 (if (vector? x)
2084 (let ((kind (vector-ref x 0)))
2085 (cond ((eq? kind 'LABEL)
2086 (let ((final-pos (vector-ref x 1)))
2087 (if final-pos
2088 (if (not (= pos final-pos))
2089 (compiler-internal-error
2090 "asm-assemble, inconsistency detected"))
2091 (vector-set! x 1 pos))
2092 (set-cdr! prev next)
2093 (loop4 prev next pos)))
2094 ((eq? kind 'DEFERRED)
2095 (let ((temp asm-code-stream))
2096 (set! asm-code-stream (asm-make-stream))
2097 ((cadr (vector-ref x 1)) pos)
2098 (let ((tail (car asm-code-stream)))
2099 (set-cdr! tail next)
2100 (let ((head (cdr asm-code-stream)))
2101 (set-cdr! prev head)
2102 (set! asm-code-stream temp)
2103 (loop4 prev head pos)))))
2104 (else
2105 (loop4 curr next pos))))
2106 (loop4 curr next (+ pos 1))))))))
2108 ;; (asm-display-listing port) produces a listing of the code stream
2109 ;; on the given output port. The bytes generated are shown in
2110 ;; hexadecimal on the left side of the listing and the right side
2111 ;; of the listing contains the text inserted by "asm-listing".
2113 (define (asm-display-listing port)
2115 (define text-col 24)
2116 (define pos-width 6)
2117 (define byte-width 2)
2119 (define (output text)
2120 (cond ((null? text))
2121 ((pair? text)
2122 (output (car text))
2123 (output (cdr text)))
2124 (else
2125 (display text port))))
2127 (define (print-hex n)
2128 (display (string-ref "0123456789ABCDEF" n) port))
2130 (define (print-byte n)
2131 (print-hex (quotient n 16))
2132 (print-hex (modulo n 16)))
2134 (define (print-pos n)
2135 (if (< n 0)
2136 (display " " port)
2137 (begin
2138 (print-byte (quotient n #x10000))
2139 (print-byte (modulo (quotient n #x100) #x100))
2140 (print-byte (modulo n #x100)))))
2142 (let loop1 ((lst (cdr asm-code-stream)) (pos asm-start-pos) (col 0))
2143 (if (null? lst)
2144 (if (> col 0)
2145 (newline port))
2146 (let ((x (car lst)))
2147 (if (vector? x)
2148 (let ((kind (vector-ref x 0)))
2149 (cond ((eq? kind 'LISTING)
2150 (let loop2 ((col col))
2151 (if (< col text-col)
2152 (begin
2153 (display (integer->char 9) port)
2154 (loop2 (* 8 (+ (quotient col 8) 1))))))
2155 (output (vector-ref x 1))
2156 (newline port)
2157 (loop1 (cdr lst) pos 0))
2158 (else
2159 (compiler-internal-error
2160 "asm-display-listing, code stream not assembled"))))
2161 (if (or (= col 0) (>= col (- text-col byte-width)))
2162 (begin
2163 (if (not (= col 0)) (newline port))
2164 (print-pos pos)
2165 (display " " port)
2166 (print-byte x)
2167 (loop1 (cdr lst) (+ pos 1) (+ (+ pos-width 1) byte-width)))
2168 (begin
2169 (print-byte x)
2170 (loop1 (cdr lst) (+ pos 1) (+ col byte-width)))))))))
2172 ;; (asm-write-code filename) outputs the code stream (i.e. the sequence
2173 ;; of bytes produced) on the named file.
2175 (define (asm-write-code filename)
2176 (with-output-to-file filename
2177 (lambda ()
2178 (let loop ((lst (cdr asm-code-stream)))
2179 (if (not (null? lst))
2180 (let ((x (car lst)))
2181 (if (vector? x)
2182 (let ((kind (vector-ref x 0)))
2183 (if (not (eq? kind 'LISTING))
2184 (compiler-internal-error
2185 "asm-write-code, code stream not assembled"))
2186 (loop (cdr lst)))
2187 (begin
2188 (write-char (integer->char x))
2189 (loop (cdr lst))))))))))
2191 (define (asm-write-hex-file filename)
2192 (with-output-to-file filename
2193 (lambda ()
2195 (define (print-hex n)
2196 (display (string-ref "0123456789ABCDEF" n)))
2198 (define (print-byte n)
2199 (print-hex (quotient n 16))
2200 (print-hex (modulo n 16)))
2202 (define (print-line type addr bytes)
2203 (let ((n (length bytes))
2204 (addr-hi (quotient addr 256))
2205 (addr-lo (modulo addr 256)))
2206 (display ":")
2207 (print-byte n)
2208 (print-byte addr-hi)
2209 (print-byte addr-lo)
2210 (print-byte type)
2211 (for-each print-byte bytes)
2212 (let ((sum
2213 (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
2214 (print-byte sum)
2215 (newline))))
2217 (let loop ((lst (cdr asm-code-stream))
2218 (pos asm-start-pos)
2219 (rev-bytes '()))
2220 (if (not (null? lst))
2221 (let ((x (car lst)))
2222 (if (vector? x)
2223 (let ((kind (vector-ref x 0)))
2224 (if (not (eq? kind 'LISTING))
2225 (compiler-internal-error
2226 "asm-write-hex-file, code stream not assembled"))
2227 (loop (cdr lst)
2228 pos
2229 rev-bytes))
2230 (let ((new-pos
2231 (+ pos 1))
2232 (new-rev-bytes
2233 (cons x
2234 (if (= (modulo pos 16) 0)
2235 (begin
2236 (print-line 0
2237 (- pos (length rev-bytes))
2238 (reverse rev-bytes))
2239 '())
2240 rev-bytes))))
2241 (loop (cdr lst)
2242 new-pos
2243 new-rev-bytes))))
2244 (begin
2245 (if (not (null? rev-bytes))
2246 (print-line 0
2247 (- pos (length rev-bytes))
2248 (reverse rev-bytes)))
2249 (print-line 1 0 '())
2250 (if #t
2251 (begin
2252 (display (- pos asm-start-pos) ##stderr-port)
2253 (display " bytes\n" ##stderr-port)))))))))
2255 ;; Utilities.
2257 (define asm-start-pos #f) ; start position of the code stream
2258 (define asm-big-endian? #f) ; endianness to use
2259 (define asm-code-stream #f) ; current code stream
2261 (define (asm-make-stream) ; create an empty stream
2262 (let ((x (cons '() '())))
2263 (set-car! x x)
2264 x))
2266 (define (asm-code-extend item) ; add an item at the end of current code stream
2267 (let* ((stream asm-code-stream)
2268 (tail (car stream))
2269 (cell (cons item '())))
2270 (set-cdr! tail cell)
2271 (set-car! stream cell)))
2273 (define (asm-pass1) ; construct fixup list and make first label assignment
2274 (let loop ((curr (cdr asm-code-stream))
2275 (fixup-lst '())
2276 (span 0)
2277 (pos asm-start-pos))
2278 (if (null? curr)
2279 (reverse fixup-lst)
2280 (let ((x (car curr)))
2281 (if (vector? x)
2282 (let ((kind (vector-ref x 0)))
2283 (cond ((eq? kind 'LABEL)
2284 (vector-set! x 1 pos) ; first approximation of position
2285 (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
2286 ((eq? kind 'DEFERRED)
2287 (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
2288 (else
2289 (loop (cdr curr) fixup-lst span pos))))
2290 (loop (cdr curr) fixup-lst (+ span 1) (+ pos 1)))))))
2292 ;(##declare (generic))
2294 (define (asm-bits-0-to-7 n) ; return bits 0 to 7 of a signed integer
2295 (modulo n #x100))
2297 (define (asm-bits-8-and-up n) ; return bits 8 and up of a signed integer
2298 (if (>= n 0)
2299 (quotient n #x100)
2300 (- (quotient (+ n 1) #x100) 1)))
2302 (define (asm-bits-16-and-up n) ; return bits 16 and up of a signed integer
2303 (if (>= n 0)
2304 (quotient n #x10000)
2305 (- (quotient (+ n 1) #x10000) 1)))
2307 (define (asm-bits-32-and-up n) ; return bits 32 and up of a signed integer
2308 (if (>= n 0)
2309 (quotient n #x100000000)
2310 (- (quotient (+ n 1) #x100000000) 1)))
2312 ; The following procedures convert floating point numbers into their
2313 ; machine representation. They perform bignum and flonum arithmetic.
2315 (define (asm-float->inexact-exponential-format x)
2317 (define (exp-form-pos x y i)
2318 (let ((i*2 (+ i i)))
2319 (let ((z (if (and (not (< asm-ieee-e-bias i*2))
2320 (not (< x y)))
2321 (exp-form-pos x (* y y) i*2)
2322 (cons x 0))))
2323 (let ((a (car z)) (b (cdr z)))
2324 (let ((i+b (+ i b)))
2325 (if (and (not (< asm-ieee-e-bias i+b))
2326 (not (< a y)))
2327 (begin
2328 (set-car! z (/ a y))
2329 (set-cdr! z i+b)))
2330 z)))))
2332 (define (exp-form-neg x y i)
2333 (let ((i*2 (+ i i)))
2334 (let ((z (if (and (< i*2 asm-ieee-e-bias-minus-1)
2335 (< x y))
2336 (exp-form-neg x (* y y) i*2)
2337 (cons x 0))))
2338 (let ((a (car z)) (b (cdr z)))
2339 (let ((i+b (+ i b)))
2340 (if (and (< i+b asm-ieee-e-bias-minus-1)
2341 (< a y))
2342 (begin
2343 (set-car! z (/ a y))
2344 (set-cdr! z i+b)))
2345 z)))))
2347 (define (exp-form x)
2348 (if (< x asm-inexact-+1)
2349 (let ((z (exp-form-neg x asm-inexact-+1/2 1)))
2350 (set-car! z (* asm-inexact-+2 (car z)))
2351 (set-cdr! z (- -1 (cdr z)))
2352 z)
2353 (exp-form-pos x asm-inexact-+2 1)))
2355 (if (negative? x)
2356 (let ((z (exp-form (- asm-inexact-0 x))))
2357 (set-car! z (- asm-inexact-0 (car z)))
2358 z)
2359 (exp-form x)))
2361 (define (asm-float->exact-exponential-format x)
2362 (let ((z (asm-float->inexact-exponential-format x)))
2363 (let ((y (car z)))
2364 (cond ((not (< y asm-inexact-+2))
2365 (set-car! z asm-ieee-+m-min)
2366 (set-cdr! z asm-ieee-e-bias-plus-1))
2367 ((not (< asm-inexact--2 y))
2368 (set-car! z asm-ieee--m-min)
2369 (set-cdr! z asm-ieee-e-bias-plus-1))
2370 (else
2371 (set-car! z
2372 (truncate (inexact->exact (* (car z) asm-inexact-m-min))))))
2373 (set-cdr! z (- (cdr z) asm-ieee-m-bits))
2374 z)))
2376 (define (asm-float->bits x) ; returns the 64 bit integer encoding the float "x"
2378 (define (bits a b)
2379 (if (< a asm-ieee-+m-min)
2380 a
2381 (+ (- a asm-ieee-+m-min)
2382 (* (+ (+ b asm-ieee-m-bits) asm-ieee-e-bias)
2383 asm-ieee-+m-min))))
2385 (let ((z (asm-float->exact-exponential-format x)))
2386 (let ((a (car z)) (b (cdr z)))
2387 (if (negative? a)
2388 (+ asm-ieee-sign-bit (bits (- 0 a) b))
2389 (bits a b)))))
2391 ; Parameters for ANSI-IEEE Std 754-1985 representation of
2392 ; doubles (i.e. 64 bit floating point numbers):
2394 (define asm-ieee-m-bits 52)
2395 (define asm-ieee-e-bits 11)
2396 (define asm-ieee-+m-min 4503599627370496) ; (expt 2 asm-ieee-m-bits)
2397 (define asm-ieee--m-min -4503599627370496) ; (- asm-ieee-+m-min)
2398 (define asm-ieee-sign-bit #x8000000000000000); (expt 2 (+ asm-ieee-e-bits asm-ieee-m-bits))
2400 (define asm-ieee-e-bias 1023) ; (- (expt 2 (- asm-ieee-e-bits 1)) 1)
2401 (define asm-ieee-e-bias-plus-1 1024) ; (+ asm-ieee-e-bias 1)
2402 (define asm-ieee-e-bias-minus-1 1022) ; (- asm-ieee-e-bias 1)
2404 (define asm-inexact-m-min (exact->inexact asm-ieee-+m-min))
2405 (define asm-inexact-+2 (exact->inexact 2))
2406 (define asm-inexact--2 (exact->inexact -2))
2407 (define asm-inexact-+1 (exact->inexact 1))
2408 (define asm-inexact-+1/2 (exact->inexact (/ 1 2)))
2409 (define asm-inexact-0 (exact->inexact 0))
2411 ;------------------------------------------------------------------------------
2413 (define min-fixnum-encoding 3)
2414 (define min-fixnum -5)
2415 (define max-fixnum 40)
2416 (define min-rom-encoding (+ min-fixnum-encoding (- max-fixnum min-fixnum) 1))
2417 (define min-ram-encoding 128)
2418 (define max-ram-encoding 4095)
2420 (define code-start #x2000)
2422 (define (predef-constants) (list))
2424 (define (predef-globals) (list))
2426 (define (encode-direct obj)
2427 (cond ((eq? obj #f)
2428 0)
2429 ((eq? obj #t)
2430 1)
2431 ((eq? obj '())
2432 2)
2433 ((and (integer? obj)
2434 (exact? obj)
2435 (>= obj min-fixnum)
2436 (<= obj max-fixnum))
2437 (+ obj (- min-fixnum-encoding min-fixnum)))
2438 (else
2439 #f)))
2441 (define (translate-constant obj)
2442 (if (char? obj)
2443 (char->integer obj)
2444 obj))
2446 (define (encode-constant obj constants) ;; TODO FOOBAR, this should return a 12 bit value
2447 (let ((o (translate-constant obj)))
2448 (let ((e (encode-direct o)))
2449 (if e
2450 e
2451 (let ((x (assq o constants)))
2452 (if x
2453 (vector-ref (cdr x) 0)
2454 (compiler-error "unknown object" obj)))))))
2456 (define (add-constant obj constants from-code? cont)
2457 (let ((o (translate-constant obj)))
2458 (let ((e (encode-direct o)))
2459 (if e
2460 (cont constants)
2461 (let ((x (assq o constants)))
2462 (if x
2463 (begin
2464 (if from-code?
2465 (vector-set! (cdr x) 2 (+ (vector-ref (cdr x) 2) 1)))
2466 (cont constants))
2467 (let* ((descr
2468 (vector #f
2469 (asm-make-label 'constant)
2470 (if from-code? 1 0)
2471 #f))
2472 (new-constants
2473 (cons (cons o descr)
2474 constants)))
2475 (cond ((pair? o)
2476 (add-constants (list (car o) (cdr o))
2477 new-constants
2478 cont))
2479 ((symbol? o)
2480 (cont new-constants))
2481 ((string? o)
2482 (let ((chars (map char->integer (string->list o))))
2483 (vector-set! descr 3 chars)
2484 (add-constant chars
2485 new-constants
2486 #f
2487 cont)))
2488 ((vector? o)
2489 (let ((elems (vector->list o)))
2490 (vector-set! descr 3 elems)
2491 (add-constant elems
2492 new-constants
2493 #f
2494 cont)))
2496 (else
2497 (cont new-constants))))))))))
2499 (define (add-constants objs constants cont)
2500 (if (null? objs)
2501 (cont constants)
2502 (add-constant (car objs)
2503 constants
2504 #f
2505 (lambda (new-constants)
2506 (add-constants (cdr objs)
2507 new-constants
2508 cont)))))
2510 (define (add-global var globals cont)
2511 (let ((x (assq var globals)))
2512 (if x
2513 (cont globals)
2514 (let ((new-globals
2515 (cons (cons var (length globals))
2516 globals)))
2517 (cont new-globals)))))
2519 (define (sort-constants constants)
2520 (let ((csts
2521 (sort-list constants
2522 (lambda (x y)
2523 (> (vector-ref (cdr x) 2)
2524 (vector-ref (cdr y) 2))))))
2525 (let loop ((i min-rom-encoding)
2526 (lst csts))
2527 (if (null? lst)
2528 (if (> i min-ram-encoding)
2529 (compiler-error "too many constants")
2530 csts) ;; TODO do some constant propagation, actually, more for globals ?
2531 (begin
2532 (vector-set! (cdr (car lst)) 0 i)
2533 (loop (+ i 1)
2534 (cdr lst)))))))
2536 (define assemble
2537 (lambda (code hex-filename)
2538 (let loop1 ((lst code)
2539 (constants (predef-constants))
2540 (globals (predef-globals))
2541 (labels (list)))
2542 (if (pair? lst)
2544 (let ((instr (car lst)))
2545 (cond ((number? instr)
2546 (loop1 (cdr lst)
2547 constants
2548 globals
2549 (cons (cons instr (asm-make-label 'label))
2550 labels)))
2551 ((eq? (car instr) 'push-constant)
2552 (add-constant (cadr instr)
2553 constants
2554 #t
2555 (lambda (new-constants)
2556 (loop1 (cdr lst)
2557 new-constants
2558 globals
2559 labels))))
2560 ((memq (car instr) '(push-global set-global))
2561 (add-global (cadr instr)
2562 globals
2563 (lambda (new-globals)
2564 (loop1 (cdr lst)
2565 constants
2566 new-globals
2567 labels))))
2568 (else
2569 (loop1 (cdr lst)
2570 constants
2571 globals
2572 labels))))
2574 (let ((constants (sort-constants constants)))
2576 (define (label-instr label opcode)
2577 (asm-at-assembly
2578 (lambda (self)
2579 2)
2580 (lambda (self)
2581 (let ((pos (- (asm-label-pos label) code-start)))
2582 (asm-8 (+ (quotient pos 256) opcode))
2583 (asm-8 (modulo pos 256))))))
2585 (define (push-constant n)
2586 (if (<= n 31)
2587 (asm-8 (+ #x00 n))
2588 (begin
2589 (asm-8 #xfc)
2590 (asm-8 n))))
2592 (define (push-stack n)
2593 (if (> n 31)
2594 (compiler-error "stack is too deep")
2595 (asm-8 (+ #x20 n))))
2597 (define (push-global n)
2598 (asm-8 (+ #x40 n)) ;; TODO we are actually limited to 16 constants, since we only have 4 bits to represent them
2599 ;; (if (> n 15) ;; ADDED prevented the stack from compiling
2600 ;; (compiler-error "too many global variables")
2601 ;; (asm-8 (+ #x40 n)))
2602 ) ;; TODO actually inline most, or put as csts
2604 (define (set-global n)
2605 (asm-8 (+ #x50 n))
2606 ;; (if (> n 15) ;; ADDED prevented the stack from compiling
2607 ;; (compiler-error "too many global variables")
2608 ;; (asm-8 (+ #x50 n)))
2609 )
2611 (define (call n)
2612 (if (> n 15)
2613 (compiler-error "call has too many arguments")
2614 (asm-8 (+ #x60 n))))
2616 (define (jump n)
2617 (if (> n 15)
2618 (compiler-error "call has too many arguments")
2619 (asm-8 (+ #x70 n))))
2621 (define (call-toplevel label)
2622 (label-instr label #x80))
2624 (define (jump-toplevel label)
2625 (label-instr label #x90))
2627 (define (goto label)
2628 (label-instr label #xa0))
2630 (define (goto-if-false label)
2631 (label-instr label #xb0))
2633 (define (closure label)
2634 (label-instr label #xc0))
2636 (define (prim n)
2637 (asm-8 (+ #xd0 n)))
2639 (define (prim.number?) (prim 0))
2640 (define (prim.+) (prim 1))
2641 (define (prim.-) (prim 2))
2642 (define (prim.*) (prim 3))
2643 (define (prim.quotient) (prim 4))
2644 (define (prim.remainder) (prim 5))
2645 (define (prim.neg) (prim 6))
2646 (define (prim.=) (prim 7))
2647 (define (prim.<) (prim 8))
2648 (define (prim.ior) (prim 9)) ;; ADDED
2649 (define (prim.>) (prim 10))
2650 (define (prim.xor) (prim 11)) ;; ADDED
2651 (define (prim.pair?) (prim 12))
2652 (define (prim.cons) (prim 13))
2653 (define (prim.car) (prim 14))
2654 (define (prim.cdr) (prim 15))
2655 (define (prim.set-car!) (prim 16))
2656 (define (prim.set-cdr!) (prim 17))
2657 (define (prim.null?) (prim 18))
2658 (define (prim.eq?) (prim 19))
2659 (define (prim.not) (prim 20))
2660 (define (prim.get-cont) (prim 21))
2661 (define (prim.graft-to-cont) (prim 22))
2662 (define (prim.return-to-cont) (prim 23))
2663 (define (prim.halt) (prim 24))
2664 (define (prim.symbol?) (prim 25))
2665 (define (prim.string?) (prim 26))
2666 (define (prim.string->list) (prim 27))
2667 (define (prim.list->string) (prim 28))
2668 (define (prim.set-fst!) (prim 29)) ;; ADDED
2669 (define (prim.set-snd!) (prim 30)) ;; ADDED
2670 (define (prim.set-trd!) (prim 31)) ;; ADDED
2672 (define (prim.print) (prim 32))
2673 (define (prim.clock) (prim 33))
2674 (define (prim.motor) (prim 34))
2675 (define (prim.led) (prim 35))
2676 (define (prim.getchar-wait) (prim 36))
2677 (define (prim.putchar) (prim 37))
2678 (define (prim.light) (prim 38))
2680 (define (prim.triplet?) (prim 39)) ;; ADDED
2681 (define (prim.triplet) (prim 40)) ;; ADDED
2682 (define (prim.fst) (prim 41)) ;; ADDED
2683 (define (prim.snd) (prim 42)) ;; ADDED
2684 (define (prim.trd) (prim 43)) ;; ADDED
2686 (define (prim.shift) (prim 45))
2687 (define (prim.pop) (prim 46))
2688 (define (prim.return) (prim 47))
2690 (define big-endian? #f)
2692 (asm-begin! code-start #f)
2694 (asm-8 #xfb)
2695 (asm-8 #xd7)
2696 (asm-8 (length constants)) ;; TODO maybe more constants ? that would mean more rom adress space, and less for ram, for now we are ok
2697 (asm-8 0)
2699 (pp (list constants: constants globals: globals)) ;; TODO debug
2701 (for-each
2702 (lambda (x)
2703 (let* ((descr (cdr x))
2704 (label (vector-ref descr 1))
2705 (obj (car x)))
2706 (asm-label label)
2707 (cond ((and (integer? obj) (exact? obj))
2708 (asm-8 0)
2709 (asm-8 (bitwise-and (arithmetic-shift obj -16) 255))
2710 (asm-8 (bitwise-and (arithmetic-shift obj -8) 255))
2711 (asm-8 (bitwise-and obj 255)))
2712 ((pair? obj) ;; TODO this is ok no matter how many csts we have
2713 (let ((obj-car (encode-constant (car obj) constants))
2714 (obj-cdr (encode-constant (cdr obj) constants)))
2715 ;; car and cdr are both represented in 12 bits, the
2716 ;; center byte being shared between the 2
2717 ;; TODO changed
2718 (asm-8 2)
2719 (asm-8
2720 (arithmetic-shift (bitwise-and obj-car #xff0) -4))
2721 (asm-8
2722 (bitwise-ior (arithmetic-shift
2723 (bitwise-and obj-car #xf)
2724 4)
2725 (arithmetic-shift
2726 (bitwise-and obj-cdr #xf00)
2727 -8)))
2728 (asm-8 (bitwise-and obj-cdr #xff))))
2729 ((symbol? obj)
2730 (asm-8 3)
2731 (asm-8 0)
2732 (asm-8 0)
2733 (asm-8 0))
2734 ((string? obj)
2735 (let ((obj-enc (encode-constant (vector-ref descr 3)
2736 constants)))
2737 (asm-8 4) ;; TODO changed
2738 (asm-8 (arithmetic-shift (bitwise-and obj-enc #xff0)
2739 -4))
2740 (asm-8 (arithmetic-shift (bitwise-and obj-enc #xf)
2741 4))
2742 (asm-8 0)))
2743 ((vector? obj)
2744 (let ((obj-enc (encode-constant (vector-ref descr 3)
2745 constants)))
2746 (asm-8 5) ;; TODO changed, and factor code
2747 (asm-8 (arithmetic-shift (bitwise-and obj-enc #xff0)
2748 -4))
2749 (asm-8 (arithmetic-shift (bitwise-and obj-enc #xf)
2750 4))
2751 (asm-8 0)))
2752 (else
2753 (compiler-error "unknown object type" obj)))))
2754 constants)
2756 (let loop2 ((lst code))
2757 (if (pair? lst)
2758 (let ((instr (car lst)))
2760 (cond ((number? instr)
2761 (let ((label (cdr (assq instr labels))))
2762 (asm-label label)))
2764 ((eq? (car instr) 'entry)
2765 (let ((np (cadr instr))
2766 (rest? (caddr instr)))
2767 (asm-8 (if rest? (- np) np))))
2769 ((eq? (car instr) 'push-constant) ;; TODO FOOBAR 12 bits for constants now
2770 (let ((n (encode-constant (cadr instr) constants)))
2771 (push-constant n)))
2773 ((eq? (car instr) 'push-stack)
2774 (push-stack (cadr instr)))
2776 ((eq? (car instr) 'push-global)
2777 (push-global (cdr (assq (cadr instr) globals))))
2779 ((eq? (car instr) 'set-global)
2780 (set-global (cdr (assq (cadr instr) globals))))
2782 ((eq? (car instr) 'call)
2783 (call (cadr instr)))
2785 ((eq? (car instr) 'jump)
2786 (jump (cadr instr)))
2788 ((eq? (car instr) 'call-toplevel)
2789 (let ((label (cdr (assq (cadr instr) labels))))
2790 (call-toplevel label)))
2792 ((eq? (car instr) 'jump-toplevel)
2793 (let ((label (cdr (assq (cadr instr) labels))))
2794 (jump-toplevel label)))
2796 ((eq? (car instr) 'goto)
2797 (let ((label (cdr (assq (cadr instr) labels))))
2798 (goto label)))
2800 ((eq? (car instr) 'goto-if-false)
2801 (let ((label (cdr (assq (cadr instr) labels))))
2802 (goto-if-false label)))
2804 ((eq? (car instr) 'closure)
2805 (let ((label (cdr (assq (cadr instr) labels))))
2806 (closure label)))
2808 ((eq? (car instr) 'prim)
2809 (case (cadr instr)
2810 ((#%number?) (prim.number?))
2811 ((#%+) (prim.+))
2812 ((#%-) (prim.-))
2813 ((#%*) (prim.*))
2814 ((#%quotient) (prim.quotient))
2815 ((#%remainder) (prim.remainder))
2816 ((#%neg) (prim.neg))
2817 ((#%=) (prim.=))
2818 ((#%<) (prim.<))
2819 ((#%ior) (prim.ior)) ;; ADDED
2820 ((#%>) (prim.>))
2821 ((#%xor) (prim.xor)) ;; ADDED
2822 ((#%pair?) (prim.pair?))
2823 ((#%cons) (prim.cons))
2824 ((#%car) (prim.car))
2825 ((#%cdr) (prim.cdr))
2826 ((#%set-car!) (prim.set-car!))
2827 ((#%set-cdr!) (prim.set-cdr!))
2828 ((#%null?) (prim.null?))
2829 ((#%eq?) (prim.eq?))
2830 ((#%not) (prim.not))
2831 ((#%get-cont) (prim.get-cont))
2832 ((#%graft-to-cont) (prim.graft-to-cont))
2833 ((#%return-to-cont) (prim.return-to-cont))
2834 ((#%halt) (prim.halt))
2835 ((#%symbol?) (prim.symbol?))
2836 ((#%string?) (prim.string?))
2837 ((#%string->list) (prim.string->list))
2838 ((#%list->string) (prim.list->string))
2839 ((#%set-fst!) (prim.set-fst!)) ;; ADDED
2840 ((#%set-snd!) (prim.set-snd!)) ;; ADDED
2841 ((#%set-trd!) (prim.set-trd!)) ;; ADDED
2843 ((#%print) (prim.print))
2844 ((#%clock) (prim.clock))
2845 ((#%motor) (prim.motor))
2846 ((#%led) (prim.led))
2847 ((#%getchar-wait) (prim.getchar-wait))
2848 ((#%putchar) (prim.putchar))
2849 ((#%light) (prim.light))
2851 ((#%triplet?) (prim.triplet?)) ;; ADDED
2852 ((#%triplet) (prim.triplet)) ;; ADDED
2853 ((#%fst) (prim.fst)) ;; ADDED
2854 ((#%snd) (prim.snd)) ;; ADDED
2855 ((#%trd) (prim.trd)) ;; ADDED
2856 (else
2857 (compiler-error "unknown primitive" (cadr instr)))))
2859 ((eq? (car instr) 'return)
2860 (prim.return))
2862 ((eq? (car instr) 'pop)
2863 (prim.pop))
2865 ((eq? (car instr) 'shift)
2866 (prim.shift))
2868 (else
2869 (compiler-error "unknown instruction" instr)))
2871 (loop2 (cdr lst)))))
2873 (asm-assemble)
2875 (asm-write-hex-file hex-filename)
2877 (asm-end!))))))
2879 (define execute
2880 (lambda (hex-filename)
2881 '
2882 (if #f
2883 (begin
2884 (shell-command "gcc -o picobit-vm picobit-vm.c")
2885 (shell-command (string-append "./picobit-vm " hex-filename)))
2886 (shell-command (string-append "./robot . 1 " hex-filename)))))
2888 (define (sort-list l <?)
2890 (define (mergesort l)
2892 (define (merge l1 l2)
2893 (cond ((null? l1) l2)
2894 ((null? l2) l1)
2895 (else
2896 (let ((e1 (car l1)) (e2 (car l2)))
2897 (if (<? e1 e2)
2898 (cons e1 (merge (cdr l1) l2))
2899 (cons e2 (merge l1 (cdr l2))))))))
2901 (define (split l)
2902 (if (or (null? l) (null? (cdr l)))
2903 l
2904 (cons (car l) (split (cddr l)))))
2906 (if (or (null? l) (null? (cdr l)))
2907 l
2908 (let* ((l1 (mergesort (split l)))
2909 (l2 (mergesort (split (cdr l)))))
2910 (merge l1 l2))))
2912 (mergesort l))
2914 ;------------------------------------------------------------------------------
2916 (define compile
2917 (lambda (filename)
2918 (let* ((node (parse-file filename))
2919 (hex-filename
2920 (string-append
2921 (path-strip-extension filename)
2922 ".hex")))
2924 ; (pp (node->expr node))
2926 (let ((ctx (comp-none node (make-init-context))))
2927 (let ((prog (linearize (optimize-code (context-code ctx)))))
2928 ; (pp (list code: prog env: (context-env ctx)))
2929 (assemble prog hex-filename)
2930 (execute hex-filename))))))
2933 (define main
2934 (lambda (filename)
2935 (compile filename)))
2937 ;------------------------------------------------------------------------------
2939 '
2940 (define (asm-write-hex-file filename)
2941 (with-output-to-file filename
2942 (lambda ()
2944 (define (print-hex n)
2945 (display (string-ref "0123456789ABCDEF" n)))
2947 (define (print-byte n)
2948 (display ", 0x")
2949 (print-hex (quotient n 16))
2950 (print-hex (modulo n 16)))
2952 (define (print-line type addr bytes)
2953 (let ((n (length bytes))
2954 (addr-hi (quotient addr 256))
2955 (addr-lo (modulo addr 256)))
2956 ; (display ":")
2957 ; (print-byte n)
2958 ; (print-byte addr-hi)
2959 ; (print-byte addr-lo)
2960 ; (print-byte type)
2961 (for-each print-byte bytes)
2962 (let ((sum
2963 (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
2964 ; (print-byte sum)
2965 (newline))))
2967 (let loop ((lst (cdr asm-code-stream))
2968 (pos asm-start-pos)
2969 (rev-bytes '()))
2970 (if (not (null? lst))
2971 (let ((x (car lst)))
2972 (if (vector? x)
2973 (let ((kind (vector-ref x 0)))
2974 (if (not (eq? kind 'LISTING))
2975 (compiler-internal-error
2976 "asm-write-hex-file, code stream not assembled"))
2977 (loop (cdr lst)
2978 pos
2979 rev-bytes))
2980 (let ((new-pos
2981 (+ pos 1))
2982 (new-rev-bytes
2983 (cons x
2984 (if (= (modulo pos 8) 0)
2985 (begin
2986 (print-line 0
2987 (- pos (length rev-bytes))
2988 (reverse rev-bytes))
2989 '())
2990 rev-bytes))))
2991 (loop (cdr lst)
2992 new-pos
2993 new-rev-bytes))))
2994 (begin
2995 (if (not (null? rev-bytes))
2996 (print-line 0
2997 (- pos (length rev-bytes))
2998 (reverse rev-bytes)))
2999 (print-line 1 0 '())))))))