| blob | 0014e8e3b50dbac8a55192daf74ac942009afb36 |
1 ; File: "picobit.scm", Time-stamp: <2006-05-08 16:04:37 feeley>
3 ; Copyright (C) 2006 by Marc Feeley, All Rights Reserved.
5 (define-macro (dummy)
6 (proper-tail-calls-set! #f)
7 #f)
8 ;(dummy)
10 ;-----------------------------------------------------------------------------
12 (define compiler-error
13 (lambda (msg . others)
14 (display "*** ERROR -- ")
15 (display msg)
16 (for-each (lambda (x) (display " ") (write x)) others)
17 (newline)
18 (exit 1)))
20 ;-----------------------------------------------------------------------------
22 (define keep
23 (lambda (keep? lst)
24 (cond ((null? lst) '())
25 ((keep? (car lst)) (cons (car lst) (keep keep? (cdr lst))))
26 (else (keep keep? (cdr lst))))))
28 (define take
29 (lambda (n lst)
30 (if (> n 0)
31 (cons (car lst) (take (- n 1) (cdr lst)))
32 '())))
34 (define drop
35 (lambda (n lst)
36 (if (> n 0)
37 (drop (- n 1) (cdr lst))
38 lst)))
40 (define repeat
41 (lambda (n x)
42 (if (> n 0)
43 (cons x (repeat (- n 1) x))
44 '())))
46 (define pos-in-list
47 (lambda (x lst)
48 (let loop ((lst lst) (i 0))
49 (cond ((not (pair? lst)) #f)
50 ((eq? (car lst) x) i)
51 (else (loop (cdr lst) (+ i 1)))))))
53 (define every
54 (lambda (pred? lst)
55 (or (null? lst)
56 (and (pred? (car lst))
57 (every pred? (cdr lst))))))
59 ;-----------------------------------------------------------------------------
61 ;; Syntax-tree node representation.
63 (define-type node
64 extender: define-type-of-node
65 parent
66 children
67 )
69 (define-type-of-node cst
70 val
71 )
73 (define-type-of-node ref
74 var
75 )
77 (define-type-of-node def
78 var
79 )
81 (define-type-of-node set
82 var
83 )
85 (define-type-of-node if
86 )
88 (define-type-of-node prc
89 params
90 rest?
91 entry-label
92 )
94 (define-type-of-node call
95 )
97 (define-type-of-node seq
98 )
100 (define-type-of-node fix
101 vars
102 )
104 (define node->expr
105 (lambda (node)
106 (cond ((cst? node)
107 (let ((val (cst-val node)))
108 (if (self-eval? val)
109 val
110 (list 'quote val))))
111 ((ref? node)
112 (var-id (ref-var node)))
113 ((def? node)
114 (list 'define
115 (var-id (def-var node))
116 (node->expr (child1 node))))
117 ((set? node)
118 (list 'set!
119 (var-id (set-var node))
120 (node->expr (child1 node))))
121 ((if? node)
122 (list 'if
123 (node->expr (child1 node))
124 (node->expr (child2 node))
125 (node->expr (child3 node))))
126 ((prc? node)
127 (if (seq? (child1 node))
128 (cons 'lambda
129 (cons (build-pattern (prc-params node) (prc-rest? node))
130 (nodes->exprs (node-children (child1 node)))))
131 (list 'lambda
132 (build-pattern (prc-params node) (prc-rest? node))
133 (node->expr (child1 node)))))
134 ((call? node)
135 (map node->expr (node-children node)))
136 ((seq? node)
137 (let ((children (node-children node)))
138 (cond ((null? children)
139 '(void))
140 ((null? (cdr children))
141 (node->expr (car children)))
142 (else
143 (cons 'begin
144 (nodes->exprs children))))))
145 ((fix? node)
146 (let ((children (node-children node)))
147 (list 'letrec
148 (map (lambda (var val)
149 (list (var-id var)
150 (node->expr val)))
151 (fix-vars node)
152 (take (- (length children) 1) children))
153 (node->expr (list-ref children (- (length children) 1))))))
154 (else
155 (compiler-error "unknown expression type" node)))))
157 (define nodes->exprs
158 (lambda (nodes)
159 (if (null? nodes)
160 '()
161 (if (seq? (car nodes))
162 (append (nodes->exprs (node-children (car nodes)))
163 (nodes->exprs (cdr nodes)))
164 (cons (node->expr (car nodes))
165 (nodes->exprs (cdr nodes)))))))
167 (define build-pattern
168 (lambda (params rest?)
169 (cond ((null? params)
170 '())
171 ((null? (cdr params))
172 (if rest?
173 (var-id (car params))
174 (list (var-id (car params)))))
175 (else
176 (cons (var-id (car params))
177 (build-pattern (cdr params) rest?))))))
179 ;-----------------------------------------------------------------------------
181 ;; Environment representation.
183 (define-type var
184 id
185 global?
186 refs
187 sets
188 defs
189 needed?
190 primitive
191 )
193 (define-type primitive
194 nargs
195 inliner
196 unspecified-result?
197 )
199 (define-type renaming
200 renamings
201 )
203 (define make-global-env
204 (lambda ()
205 (list (make-var '#%number? #t '() '() '() #f (make-primitive 1 #f #f))
206 (make-var '#%+ #t '() '() '() #f (make-primitive 2 #f #f))
207 (make-var '#%- #t '() '() '() #f (make-primitive 2 #f #f))
208 (make-var '#%* #t '() '() '() #f (make-primitive 2 #f #f))
209 (make-var '#%quotient #t '() '() '() #f (make-primitive 2 #f #f))
210 (make-var '#%remainder #t '() '() '() #f (make-primitive 2 #f #f))
211 (make-var '#%neg #t '() '() '() #f (make-primitive 1 #f #f))
212 (make-var '#%= #t '() '() '() #f (make-primitive 2 #f #f))
213 (make-var '#%< #t '() '() '() #f (make-primitive 2 #f #f))
214 (make-var '#%ior #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED
215 (make-var '#%> #t '() '() '() #f (make-primitive 2 #f #f))
216 (make-var '#%xor #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED
217 (make-var '#%pair? #t '() '() '() #f (make-primitive 1 #f #f))
218 (make-var '#%cons #t '() '() '() #f (make-primitive 2 #f #f))
219 (make-var '#%car #t '() '() '() #f (make-primitive 1 #f #f))
220 (make-var '#%cdr #t '() '() '() #f (make-primitive 1 #f #f))
221 (make-var '#%set-car! #t '() '() '() #f (make-primitive 2 #f #t))
222 (make-var '#%set-cdr! #t '() '() '() #f (make-primitive 2 #f #t))
223 (make-var '#%null? #t '() '() '() #f (make-primitive 1 #f #f))
224 (make-var '#%eq? #t '() '() '() #f (make-primitive 2 #f #f))
225 (make-var '#%not #t '() '() '() #f (make-primitive 1 #f #f))
226 (make-var '#%get-cont #t '() '() '() #f (make-primitive 0 #f #f))
227 (make-var '#%graft-to-cont #t '() '() '() #f (make-primitive 2 #f #f))
228 (make-var '#%return-to-cont #t '() '() '() #f (make-primitive 2 #f #f))
229 (make-var '#%halt #t '() '() '() #f (make-primitive 0 #f #t))
230 (make-var '#%symbol? #t '() '() '() #f (make-primitive 1 #f #f))
231 (make-var '#%string? #t '() '() '() #f (make-primitive 1 #f #f))
232 (make-var '#%string->list #t '() '() '() #f (make-primitive 1 #f #f))
233 (make-var '#%list->string #t '() '() '() #f (make-primitive 1 #f #f))
235 (make-var '#%make-u8vector #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED
236 (make-var '#%u8vector-ref #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED
237 (make-var '#%u8vector-set! #t '() '() '() #f (make-primitive 3 #f #t)) ;; ADDED
239 (make-var '#%print #t '() '() '() #f (make-primitive 1 #f #t))
240 (make-var '#%clock #t '() '() '() #f (make-primitive 0 #f #f))
241 (make-var '#%motor #t '() '() '() #f (make-primitive 2 #f #t))
242 (make-var '#%led #t '() '() '() #f (make-primitive 3 #f #t))
243 (make-var '#%led2-color #t '() '() '() #f (make-primitive 1 #f #t))
244 (make-var '#%getchar-wait #t '() '() '() #f (make-primitive 2 #f #f))
245 (make-var '#%putchar #t '() '() '() #f (make-primitive 2 #f #t))
246 (make-var '#%beep #t '() '() '() #f (make-primitive 2 #f #f))
247 (make-var '#%adc #t '() '() '() #f (make-primitive 1 #f #f))
248 (make-var '#%u8vector? #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED, was dac
249 (make-var '#%sernum #t '() '() '() #f (make-primitive 0 #f #f))
250 (make-var '#%u8vector-length #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED
252 (make-var '#%readyq #t '() '() '() #f #f)
254 )))
256 ;; list of primitives that can be safely substituted for the equivalent
257 ;; function when it is called.
258 ;; this saves the calls to the primitive wrapper functions, which are still
259 ;; needed if a program needs the value of a "primitive", for example in :
260 ;; (define foo car)
261 ;; TODO have the arg length ?
262 (define substitute-primitives
263 '((number? . #%number?)
264 (quotient . #%quotient)
265 (remainder . #%remainder)
266 (= . #%=)
267 (< . #%<)
268 (> . #%>)
269 (pair? . #%pair?)
270 (cons . #%cons)
271 (car . #%car)
272 (cdr . #%cdr)
273 (set-car! . #%set-car!)
274 (set-cdr! . #%set-cdr!)
275 (null? . #%null?)
276 (eq? . #%eq?)
277 (not . #%not)
278 (modulo . #%remainder)
279 (string->list . #%string->list)
280 (list->string . #%list->string)
281 (clock . #%clock)
282 (beep . #%beep)
283 (light . #%adc)
284 (adc . #%adc)
285 (sernum . #%sernum)
286 (motor . #%motor)
287 (led . #%led)
288 (bitwise-ior . #%ior)
289 (bitwise-xor . #%xor)
290 (current-time . #%clock)
291 (u8vector-length . #%u8vector-length)
292 (u8vector-ref . #%u8vector-ref)
293 (u8vector-set! . #%u8vector-set!)
294 ))
296 (define env-lookup
297 (lambda (env id)
298 (let loop ((lst env) (id id))
299 (let ((b (car lst)))
300 (cond ((and (renaming? b)
301 (assq id (renaming-renamings b)))
302 =>
303 (lambda (x)
304 (loop (cdr lst) (cadr x))))
305 ((and (var? b)
306 (eq? (var-id b) id))
307 b)
308 ((null? (cdr lst))
309 (let ((x (make-var id #t '() '() '() #f #f)))
310 (set-cdr! lst (cons x '()))
311 x))
312 (else
313 (loop (cdr lst) id)))))))
315 (define env-extend
316 (lambda (env ids def)
317 (append (map (lambda (id)
318 (make-var id #f '() '() (list def) #f #f))
319 ids)
320 env)))
322 (define env-extend-renamings
323 (lambda (env renamings)
324 (cons (make-renaming renamings) env)))
326 ;-----------------------------------------------------------------------------
328 ;; Parsing.
330 (define parse-program
331 (lambda (expr env)
332 (let ((x (parse-top expr env)))
333 (cond ((null? x)
334 (parse 'value #f env))
335 ((null? (cdr x))
336 (car x))
337 (else
338 (let ((r (make-seq #f x)))
339 (for-each (lambda (y) (node-parent-set! y r)) x)
340 r))))))
342 (define parse-top
343 (lambda (expr env)
344 (cond ((and (pair? expr)
345 (eq? (car expr) 'begin))
346 (parse-top-list (cdr expr) env))
347 ((and (pair? expr)
348 (eq? (car expr) 'hide))
349 (parse-top-hide (cadr expr) (cddr expr) env))
350 ((and (pair? expr)
351 (eq? (car expr) 'rename))
352 (parse-top-rename (cadr expr) (cddr expr) env))
353 ((and (pair? expr)
354 (eq? (car expr) 'define))
355 (let ((var
356 (if (pair? (cadr expr))
357 (car (cadr expr))
358 (cadr expr)))
359 (val
360 (if (pair? (cadr expr))
361 (cons 'lambda (cons (cdr (cadr expr)) (cddr expr)))
362 (caddr expr))))
363 (let* ((var2 (env-lookup env var))
364 (val2 (parse 'value val env))
365 (r (make-def #f (list val2) var2)))
366 (node-parent-set! val2 r)
367 (var-defs-set! var2 (cons r (var-defs var2)))
368 (list r))))
369 (else
370 (list (parse 'value expr env))))))
372 (define parse-top-list
373 (lambda (lst env)
374 (if (pair? lst)
375 (append (parse-top (car lst) env)
376 (parse-top-list (cdr lst) env))
377 '())))
379 (define parse-top-hide
380 (lambda (renamings body env)
381 (append
382 (parse-top-list body
383 (env-extend-renamings env renamings))
384 #|
385 (parse-top-list
386 (map (lambda (x) (list 'define (car x) (cadr x))) renamings)
387 env)
388 |#
389 )))
391 (define parse-top-rename
392 (lambda (renamings body env)
393 (parse-top-list body
394 (env-extend-renamings env renamings))))
396 (define parse
397 (lambda (use expr env)
398 (cond ((self-eval? expr)
399 (make-cst #f '() expr))
400 ((symbol? expr)
401 (let* ((var (env-lookup env expr))
402 (r (make-ref #f '() var)))
403 (var-refs-set! var (cons r (var-refs var)))
404 r))
405 ((and (pair? expr) ;; ADDED, when we have a true macroexpander, get rid
406 (eq? (car expr) 'cond))
407 (parse use
408 `(if ,(caadr expr)
409 (begin ,@(cdadr expr))
410 ,(if (null? (cddr expr))
411 #f
412 `(cond ,@(cddr expr))))
413 env))
414 ((and (pair? expr)
415 (eq? (car expr) 'set!))
416 (let ((var (env-lookup env (cadr expr))))
417 (if (var-global? var)
418 (let* ((val (parse 'value (caddr expr) env))
419 (r (make-set #f (list val) var)))
420 (node-parent-set! val r)
421 (var-sets-set! var (cons r (var-sets var)))
422 r)
423 (compiler-error "set! is only permitted on global variables"))))
424 ((and (pair? expr) ;; TODO since literal vectors are quoted, this does the job
425 (eq? (car expr) 'quote))
426 (make-cst #f '() (cadr expr)))
427 ((and (pair? expr)
428 (eq? (car expr) 'if))
429 (let* ((a (parse 'test (cadr expr) env))
430 (b (parse use (caddr expr) env))
431 (c (if (null? (cdddr expr))
432 (make-cst #f '() #f)
433 (parse use (cadddr expr) env)))
434 (r (make-if #f (list a b c))))
435 (node-parent-set! a r)
436 (node-parent-set! b r)
437 (node-parent-set! c r)
438 r))
439 ((and (pair? expr)
440 (eq? (car expr) 'lambda))
441 (let* ((pattern (cadr expr))
442 (ids (extract-ids pattern))
443 (r (make-prc #f '() #f (has-rest-param? pattern) #f))
444 (new-env (env-extend env ids r))
445 (body (parse-body (cddr expr) new-env)))
446 (prc-params-set! r (map (lambda (id) (env-lookup new-env id)) ids))
447 (node-children-set! r (list body))
448 (node-parent-set! body r)
449 r))
450 ((and (pair? expr)
451 (eq? (car expr) 'begin))
452 (let* ((exprs (map (lambda (x) (parse 'value x env)) (cdr expr)))
453 (r (make-seq #f exprs)))
454 (for-each (lambda (x) (node-parent-set! x r)) exprs)
455 r))
456 ((and (pair? expr)
457 (eq? (car expr) 'let))
458 (if (symbol? (cadr expr))
459 (compiler-error "named let is not implemented")
460 (parse use
461 (cons (cons 'lambda
462 (cons (map car (cadr expr))
463 (cddr expr)))
464 (map cadr (cadr expr)))
465 env)))
466 ((and (pair? expr)
467 (eq? (car expr) 'let*))
468 (if (null? (cadr expr))
469 (parse use
470 (cons 'let (cdr expr))
471 env)
472 (parse use
473 (list 'let
474 (list (list (caar (cadr expr))
475 (cadar (cadr expr))))
476 (cons 'let*
477 (cons (cdr (cadr expr))
478 (cddr expr))))
479 env)))
480 ((and (pair? expr)
481 (eq? (car expr) 'and))
482 (cond ((null? (cdr expr))
483 (parse use
484 #t
485 env))
486 ((null? (cddr expr))
487 (parse use
488 (cadr expr)
489 env))
490 (else
491 (parse use
492 (list 'if
493 (cadr expr)
494 (cons 'and (cddr expr))
495 #f)
496 env))))
497 ((and (pair? expr)
498 (eq? (car expr) 'or))
499 (cond ((null? (cdr expr))
500 (parse use
501 #f
502 env))
503 ((null? (cddr expr))
504 (parse use
505 (cadr expr)
506 env))
507 ((eq? use 'test)
508 (parse use
509 (list 'if
510 (cadr expr)
511 #t
512 (cons 'or (cddr expr)))
513 env))
514 (else
515 (parse use
516 (let ((v (gensym)))
517 (list 'let
518 (list (list v (cadr expr)))
519 (list 'if
520 v
521 v
522 (cons 'or (cddr expr)))))
523 env))))
524 ;; primitive substitution here
525 ;; TODO do this optimization in the following pass instead of at parse time ?
526 ((and (pair? expr)
527 (assoc (car expr) substitute-primitives))
528 =>
529 (lambda (prim)
530 (parse use
531 (cons (cdr prim) (cdr expr))
532 env)))
533 ;; binary arthimetic operations can use primitives directly
534 ;; TODO if more than one arg, unroll ? would save calls
535 ((and (pair? expr)
536 (= (length (cdr expr)) 2)
537 (assoc (car expr) '((+ . #%+) (- . #%-) (* . #%*))))
538 =>
539 (lambda (prim)
540 (parse use
541 (cons (cdr prim) (cdr expr))
542 env)))
543 ((and (pair? expr)
544 (memq (car expr)
545 '(quote quasiquote unquote unquote-splicing lambda if
546 set! cond and or case let let* letrec begin do define
547 delay)))
548 (compiler-error "the compiler does not implement the special form" (car expr)))
549 ((pair? expr)
550 (let* ((exprs (map (lambda (x) (parse 'value x env)) expr))
551 (r (make-call #f exprs)))
552 (for-each (lambda (x) (node-parent-set! x r)) exprs)
553 r))
554 (else
555 (compiler-error "unknown expression" expr)))))
557 (define parse-body
558 (lambda (exprs env)
559 (parse 'value (cons 'begin exprs) env)))
561 (define self-eval?
562 (lambda (expr)
563 (or (number? expr)
564 (char? expr)
565 (boolean? expr)
566 (string? expr))))
568 (define extract-ids
569 (lambda (pattern)
570 (if (pair? pattern)
571 (cons (car pattern) (extract-ids (cdr pattern)))
572 (if (symbol? pattern)
573 (cons pattern '())
574 '()))))
576 (define has-rest-param?
577 (lambda (pattern)
578 (if (pair? pattern)
579 (has-rest-param? (cdr pattern))
580 (symbol? pattern))))
582 ;-----------------------------------------------------------------------------
584 ;; Compilation context representation.
586 (define-type context
587 code
588 env
589 env2
590 )
592 (define context-change-code
593 (lambda (ctx code)
594 (make-context code
595 (context-env ctx)
596 (context-env2 ctx))))
598 (define context-change-env
599 (lambda (ctx env)
600 (make-context (context-code ctx)
601 env
602 (context-env2 ctx))))
604 (define context-change-env2
605 (lambda (ctx env2)
606 (make-context (context-code ctx)
607 (context-env ctx)
608 env2)))
610 (define make-init-context
611 (lambda ()
612 (make-context (make-init-code)
613 (make-init-env)
614 #f)))
616 (define context-make-label
617 (lambda (ctx)
618 (context-change-code ctx (code-make-label (context-code ctx)))))
620 (define context-last-label
621 (lambda (ctx)
622 (code-last-label (context-code ctx))))
624 (define context-add-bb
625 (lambda (ctx label)
626 (context-change-code ctx (code-add-bb (context-code ctx) label))))
628 (define context-add-instr
629 (lambda (ctx instr)
630 (context-change-code ctx (code-add-instr (context-code ctx) instr))))
632 ;; Representation of code.
634 (define-type code
635 last-label
636 rev-bbs
637 )
639 (define-type bb
640 label
641 rev-instrs
642 )
644 (define make-init-code
645 (lambda ()
646 (make-code 0
647 (list (make-bb 0 (list))))))
649 (define code-make-label
650 (lambda (code)
651 (let ((label (+ (code-last-label code) 1)))
652 (make-code label
653 (code-rev-bbs code)))))
655 (define code-add-bb
656 (lambda (code label)
657 (make-code
658 (code-last-label code)
659 (cons (make-bb label '())
660 (code-rev-bbs code)))))
662 (define code-add-instr
663 (lambda (code instr)
664 (let* ((rev-bbs (code-rev-bbs code))
665 (bb (car rev-bbs))
666 (rev-instrs (bb-rev-instrs bb)))
667 (make-code
668 (code-last-label code)
669 (cons (make-bb (bb-label bb)
670 (cons instr rev-instrs))
671 (cdr rev-bbs))))))
673 ;; Representation of compile-time stack.
675 (define-type stack
676 size ; number of slots
677 slots ; for each slot, the variable (or #f) contained in the slot
678 )
680 (define make-init-stack
681 (lambda ()
682 (make-stack 0 '())))
684 (define stack-extend
685 (lambda (x nb-slots stk)
686 (let ((size (stack-size stk)))
687 (make-stack
688 (+ size nb-slots)
689 (append (repeat nb-slots x) (stack-slots stk))))))
691 (define stack-discard
692 (lambda (nb-slots stk)
693 (let ((size (stack-size stk)))
694 (make-stack
695 (- size nb-slots)
696 (list-tail (stack-slots stk) nb-slots)))))
698 ;; Representation of compile-time environment.
700 (define-type env
701 local
702 closed
703 )
705 (define make-init-env
706 (lambda ()
707 (make-env (make-init-stack)
708 '())))
710 (define env-change-local
711 (lambda (env local)
712 (make-env local
713 (env-closed env))))
715 (define env-change-closed
716 (lambda (env closed)
717 (make-env (env-local env)
718 closed)))
720 (define find-local-var
721 (lambda (var env)
722 (let ((i (pos-in-list var (stack-slots (env-local env)))))
723 (or i
724 (- (+ (pos-in-list var (env-closed env)) 1))))))
726 (define prc->env
727 (lambda (prc)
728 (make-env
729 (let ((params (prc-params prc)))
730 (make-stack (length params)
731 (append (map var-id params) '())))
732 (let ((vars (varset->list (non-global-fv prc))))
733 ; (pp (map var-id vars))
734 (map var-id vars)))))
736 ;-----------------------------------------------------------------------------
738 (define gen-instruction
739 (lambda (instr nb-pop nb-push ctx)
740 (let* ((env
741 (context-env ctx))
742 (stk
743 (stack-extend #f
744 nb-push
745 (stack-discard nb-pop
746 (env-local env)))))
747 (context-add-instr (context-change-env ctx (env-change-local env stk))
748 instr))))
750 (define gen-entry
751 (lambda (nparams rest? ctx)
752 (gen-instruction (list 'entry nparams rest?) 0 0 ctx)))
754 (define gen-push-constant
755 (lambda (val ctx)
756 (gen-instruction (list 'push-constant val) 0 1 ctx)))
758 (define gen-push-unspecified
759 (lambda (ctx)
760 (gen-push-constant #f ctx)))
762 (define gen-push-local-var
763 (lambda (var ctx)
764 ; (pp (list var: var local: (stack-slots (env-local (context-env ctx))) (env-closed (context-env ctx))))
765 (let ((i (find-local-var var (context-env ctx))))
766 (if (>= i 0)
767 (gen-push-stack i ctx)
768 (gen-push-stack
769 (+ 1 ;; TODO the +1 was added because closures are not really pairs anymore, they only have a cdr
770 (- -1 i)
771 (length (stack-slots (env-local (context-env ctx))))) ctx)))))
773 (define gen-push-stack
774 (lambda (pos ctx)
775 (gen-instruction (list 'push-stack pos) 0 1 ctx)))
777 (define gen-push-global
778 (lambda (var ctx)
779 (gen-instruction (list 'push-global var) 0 1 ctx)))
781 (define gen-set-global
782 (lambda (var ctx)
783 (gen-instruction (list 'set-global var) 1 0 ctx)))
785 (define gen-call
786 (lambda (nargs ctx)
787 (gen-instruction (list 'call nargs) (+ nargs 1) 1 ctx)))
789 (define gen-jump
790 (lambda (nargs ctx)
791 (gen-instruction (list 'jump nargs) (+ nargs 1) 1 ctx)))
793 (define gen-call-toplevel
794 (lambda (nargs id ctx)
795 (gen-instruction (list 'call-toplevel id) nargs 1 ctx)))
797 (define gen-jump-toplevel
798 (lambda (nargs id ctx)
799 (gen-instruction (list 'jump-toplevel id) nargs 1 ctx)))
801 (define gen-goto
802 (lambda (label ctx)
803 (gen-instruction (list 'goto label) 0 0 ctx)))
805 (define gen-goto-if-false
806 (lambda (label-false label-true ctx)
807 (gen-instruction (list 'goto-if-false label-false label-true) 1 0 ctx)))
809 (define gen-closure
810 (lambda (label-entry ctx)
811 (gen-instruction (list 'closure label-entry) 1 1 ctx)))
813 (define gen-prim
814 (lambda (id nargs unspec-result? ctx)
815 (gen-instruction
816 (list 'prim id)
817 nargs
818 (if unspec-result? 0 1)
819 ctx)))
821 (define gen-shift
822 (lambda (n ctx)
823 (if (> n 0)
824 (gen-instruction (list 'shift) 1 0 (gen-shift (- n 1) ctx))
825 ctx)))
827 (define gen-pop
828 (lambda (ctx)
829 (gen-instruction (list 'pop) 1 0 ctx)))
831 (define gen-return
832 (lambda (ctx)
833 (let ((ss (stack-size (env-local (context-env ctx)))))
834 (gen-instruction (list 'return) ss 0 ctx))))
836 ;-----------------------------------------------------------------------------
838 (define child1
839 (lambda (node)
840 (car (node-children node))))
842 (define child2
843 (lambda (node)
844 (cadr (node-children node))))
846 (define child3
847 (lambda (node)
848 (caddr (node-children node))))
850 (define comp-none
851 (lambda (node ctx)
853 (cond ((or (cst? node)
854 (ref? node)
855 (prc? node))
856 ctx)
858 ((def? node)
859 (let ((var (def-var node)))
860 (if (toplevel-prc-with-non-rest-correct-calls? var)
861 (comp-prc (child1 node) #f ctx)
862 (if (var-needed? var)
863 (let ((ctx2 (comp-push (child1 node) ctx)))
864 (gen-set-global (var-id var) ctx2))
865 (comp-none (child1 node) ctx)))))
867 ((set? node)
868 (let ((var (set-var node)))
869 (if (var-needed? var)
870 (let ((ctx2 (comp-push (child1 node) ctx)))
871 (gen-set-global (var-id var) ctx2))
872 (comp-none (child1 node) ctx))))
874 ((if? node)
875 (let* ((ctx2
876 (context-make-label ctx))
877 (label-then
878 (context-last-label ctx2))
879 (ctx3
880 (context-make-label ctx2))
881 (label-else
882 (context-last-label ctx3))
883 (ctx4
884 (context-make-label ctx3))
885 (label-then-join
886 (context-last-label ctx4))
887 (ctx5
888 (context-make-label ctx4))
889 (label-else-join
890 (context-last-label ctx5))
891 (ctx6
892 (context-make-label ctx5))
893 (label-join
894 (context-last-label ctx6))
895 (ctx7
896 (comp-test (child1 node) label-then label-else ctx6))
897 (ctx8
898 (gen-goto
899 label-else-join
900 (comp-none (child3 node)
901 (context-change-env2
902 (context-add-bb ctx7 label-else)
903 #f))))
904 (ctx9
905 (gen-goto
906 label-then-join
907 (comp-none (child2 node)
908 (context-change-env
909 (context-add-bb ctx8 label-then)
910 (context-env2 ctx7)))))
911 (ctx10
912 (gen-goto
913 label-join
914 (context-add-bb ctx9 label-else-join)))
915 (ctx11
916 (gen-goto
917 label-join
918 (context-add-bb ctx10 label-then-join)))
919 (ctx12
920 (context-add-bb ctx11 label-join)))
921 ctx12))
923 ((call? node)
924 (comp-call node 'none ctx))
926 ((seq? node)
927 (let ((children (node-children node)))
928 (if (null? children)
929 ctx
930 (let loop ((lst children)
931 (ctx ctx))
932 (if (null? (cdr lst))
933 (comp-none (car lst) ctx)
934 (loop (cdr lst)
935 (comp-none (car lst) ctx)))))))
937 (else
938 (compiler-error "unknown expression type" node)))))
940 (define comp-tail
941 (lambda (node ctx)
943 (cond ((or (cst? node)
944 (ref? node)
945 (def? node)
946 (set? node)
947 (prc? node)
948 ; (call? node)
949 )
950 (gen-return (comp-push node ctx)))
952 ((if? node)
953 (let* ((ctx2
954 (context-make-label ctx))
955 (label-then
956 (context-last-label ctx2))
957 (ctx3
958 (context-make-label ctx2))
959 (label-else
960 (context-last-label ctx3))
961 (ctx4
962 (comp-test (child1 node) label-then label-else ctx3))
963 (ctx5
964 (comp-tail (child3 node)
965 (context-change-env2
966 (context-add-bb ctx4 label-else)
967 #f)))
968 (ctx6
969 (comp-tail (child2 node)
970 (context-change-env
971 (context-add-bb ctx5 label-then)
972 (context-env2 ctx4)))))
973 ctx6))
975 ((call? node)
976 (comp-call node 'tail ctx))
978 ((seq? node)
979 (let ((children (node-children node)))
980 (if (null? children)
981 (gen-return (gen-push-unspecified ctx))
982 (let loop ((lst children)
983 (ctx ctx))
984 (if (null? (cdr lst))
985 (comp-tail (car lst) ctx)
986 (loop (cdr lst)
987 (comp-none (car lst) ctx)))))))
989 (else
990 (compiler-error "unknown expression type" node)))))
992 (define comp-push
993 (lambda (node ctx)
995 '(
996 (display "--------------\n")
997 (pp (node->expr node))
998 (pp env)
999 (pp stk)
1000 )
1002 (cond ((cst? node)
1003 (let ((val (cst-val node)))
1004 (gen-push-constant val ctx)))
1006 ((ref? node)
1007 (let ((var (ref-var node)))
1008 (if (var-global? var)
1009 (if (null? (var-defs var))
1010 (compiler-error "undefined variable:" (var-id var))
1011 (let ((val (child1 (car (var-defs var)))))
1012 (if (and (not (mutable-var? var))
1013 (cst? val)) ;; immutable global, counted as cst
1014 (gen-push-constant (cst-val val) ctx)
1015 (gen-push-global (var-id var) ctx))))
1016 (gen-push-local-var (var-id var) ctx)))) ;; TODO globals as csts seem to work (but only for constant-values ones, like it probably should)
1018 ((or (def? node)
1019 (set? node))
1020 (gen-push-unspecified (comp-none node ctx)))
1022 ((if? node)
1023 (let* ((ctx2
1024 (context-make-label ctx))
1025 (label-then
1026 (context-last-label ctx2))
1027 (ctx3
1028 (context-make-label ctx2))
1029 (label-else
1030 (context-last-label ctx3))
1031 (ctx4
1032 (context-make-label ctx3))
1033 (label-then-join
1034 (context-last-label ctx4))
1035 (ctx5
1036 (context-make-label ctx4))
1037 (label-else-join
1038 (context-last-label ctx5))
1039 (ctx6
1040 (context-make-label ctx5))
1041 (label-join
1042 (context-last-label ctx6))
1043 (ctx7
1044 (comp-test (child1 node) label-then label-else ctx6))
1045 (ctx8
1046 (gen-goto
1047 label-else-join
1048 (comp-push (child3 node)
1049 (context-change-env2
1050 (context-add-bb ctx7 label-else)
1051 #f))))
1052 (ctx9
1053 (gen-goto
1054 label-then-join
1055 (comp-push (child2 node)
1056 (context-change-env
1057 (context-add-bb ctx8 label-then)
1058 (context-env2 ctx7)))))
1059 (ctx10
1060 (gen-goto
1061 label-join
1062 (context-add-bb ctx9 label-else-join)))
1063 (ctx11
1064 (gen-goto
1065 label-join
1066 (context-add-bb ctx10 label-then-join)))
1067 (ctx12
1068 (context-add-bb ctx11 label-join)))
1069 ctx12))
1071 ((prc? node)
1072 (comp-prc node #t ctx))
1074 ((call? node)
1075 (comp-call node 'push ctx))
1077 ((seq? node)
1078 (let ((children (node-children node)))
1079 (if (null? children)
1080 (gen-push-unspecified ctx)
1081 (let loop ((lst children)
1082 (ctx ctx))
1083 (if (null? (cdr lst))
1084 (comp-push (car lst) ctx)
1085 (loop (cdr lst)
1086 (comp-none (car lst) ctx)))))))
1088 (else
1089 (compiler-error "unknown expression type" node)))))
1091 (define (build-closure label-entry vars ctx)
1093 (define (build vars ctx)
1094 (if (null? vars)
1095 (gen-push-constant '() ctx)
1096 (gen-prim '#%cons
1097 2
1098 #f
1099 (build (cdr vars)
1100 (gen-push-local-var (car vars) ctx)))))
1102 (if (null? vars)
1103 (gen-closure label-entry
1104 (gen-push-constant '() ctx))
1105 (gen-closure label-entry
1106 (build vars ctx))))
1107 ;; 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
1109 (define comp-prc
1110 (lambda (node closure? ctx)
1111 (let* ((ctx2
1112 (context-make-label ctx))
1113 (label-entry
1114 (context-last-label ctx2))
1115 (ctx3
1116 (context-make-label ctx2))
1117 (label-continue
1118 (context-last-label ctx3))
1119 (body-env
1120 (prc->env node))
1121 (ctx4
1122 (if closure?
1123 (build-closure label-entry (env-closed body-env) ctx3)
1124 ctx3))
1125 (ctx5
1126 (gen-goto label-continue ctx4))
1127 (ctx6
1128 (gen-entry (length (prc-params node))
1129 (prc-rest? node)
1130 (context-add-bb (context-change-env ctx5
1131 body-env)
1132 label-entry)))
1133 (ctx7
1134 (comp-tail (child1 node) ctx6)))
1135 (prc-entry-label-set! node label-entry)
1136 (context-add-bb (context-change-env ctx7 (context-env ctx5))
1137 label-continue))))
1139 (define comp-call
1140 (lambda (node reason ctx)
1141 (let* ((op (child1 node))
1142 (args (cdr (node-children node)))
1143 (nargs (length args)))
1144 (let loop ((lst args)
1145 (ctx ctx))
1146 (if (pair? lst)
1148 (let ((arg (car lst)))
1149 (loop (cdr lst)
1150 (comp-push arg ctx)))
1152 (cond ((and (ref? op)
1153 (var-primitive (ref-var op)))
1154 (let* ((var (ref-var op))
1155 (id (var-id var))
1156 (primitive (var-primitive var))
1157 (prim-nargs (primitive-nargs primitive)))
1159 (define use-result
1160 (lambda (ctx2)
1161 (cond ((eq? reason 'tail)
1162 (gen-return
1163 (if (primitive-unspecified-result? primitive)
1164 (gen-push-unspecified ctx2)
1165 ctx2)))
1166 ((eq? reason 'push)
1167 (if (primitive-unspecified-result? primitive)
1168 (gen-push-unspecified ctx2)
1169 ctx2))
1170 (else
1171 (if (primitive-unspecified-result? primitive)
1172 ctx2
1173 (gen-pop ctx2))))))
1175 (use-result
1176 (if (primitive-inliner primitive)
1177 ((primitive-inliner primitive) ctx)
1178 (if (not (= nargs prim-nargs))
1179 (compiler-error "primitive called with wrong number of arguments" id)
1180 (gen-prim
1181 id
1182 prim-nargs
1183 (primitive-unspecified-result? primitive)
1184 ctx))))))
1187 ((and (ref? op)
1188 (toplevel-prc-with-non-rest-correct-calls? (ref-var op)))
1189 =>
1190 (lambda (prc)
1191 (cond ((eq? reason 'tail)
1192 (gen-jump-toplevel nargs prc ctx))
1193 ((eq? reason 'push)
1194 (gen-call-toplevel nargs prc ctx))
1195 (else
1196 (gen-pop (gen-call-toplevel nargs prc ctx))))))
1198 (else
1199 (let ((ctx2 (comp-push op ctx)))
1200 (cond ((eq? reason 'tail)
1201 (gen-jump nargs ctx2))
1202 ((eq? reason 'push)
1203 (gen-call nargs ctx2))
1204 (else
1205 (gen-pop (gen-call nargs ctx2))))))))))))
1207 (define comp-test
1208 (lambda (node label-true label-false ctx)
1209 (cond ((cst? node)
1210 (let ((ctx2
1211 (gen-goto
1212 (let ((val (cst-val node)))
1213 (if val
1214 label-true
1215 label-false))
1216 ctx)))
1217 (context-change-env2 ctx2 (context-env ctx2))))
1219 ((or (ref? node)
1220 (def? node)
1221 (set? node)
1222 (if? node)
1223 (call? node)
1224 (seq? node))
1225 (let* ((ctx2
1226 (comp-push node ctx))
1227 (ctx3
1228 (gen-goto-if-false label-false label-true ctx2)))
1229 (context-change-env2 ctx3 (context-env ctx3))))
1231 ((prc? node)
1232 (let ((ctx2
1233 (gen-goto label-true ctx)))
1234 (context-change-env2 ctx2 (context-env ctx2))))
1236 (else
1237 (compiler-error "unknown expression type" node)))))
1239 ;-----------------------------------------------------------------------------
1241 (define toplevel-prc?
1242 (lambda (var)
1243 (and (not (mutable-var? var))
1244 (let ((d (var-defs var)))
1245 (and (pair? d)
1246 (null? (cdr d))
1247 (let ((val (child1 (car d))))
1248 (and (prc? val)
1249 val)))))))
1251 (define toplevel-prc-with-non-rest-correct-calls?
1252 (lambda (var)
1253 (let ((prc (toplevel-prc? var)))
1254 (and prc
1255 (not (prc-rest? prc))
1256 (every (lambda (r)
1257 (let ((parent (node-parent r)))
1258 (and (call? parent)
1259 (eq? (child1 parent) r)
1260 (= (length (prc-params prc))
1261 (- (length (node-children parent)) 1)))))
1262 (var-refs var))
1263 prc))))
1265 (define mutable-var?
1266 (lambda (var)
1267 (not (null? (var-sets var)))))
1269 (define global-fv
1270 (lambda (node)
1271 (list->varset
1272 (keep var-global?
1273 (varset->list (fv node))))))
1275 (define non-global-fv
1276 (lambda (node)
1277 (list->varset
1278 (keep (lambda (x) (not (var-global? x)))
1279 (varset->list (fv node))))))
1281 (define fv
1282 (lambda (node)
1283 (cond ((cst? node)
1284 (varset-empty))
1285 ((ref? node)
1286 (let ((var (ref-var node)))
1287 (varset-singleton var)))
1288 ((def? node)
1289 (let ((var (def-var node))
1290 (val (child1 node)))
1291 (varset-union
1292 (varset-singleton var)
1293 (fv val))))
1294 ((set? node)
1295 (let ((var (set-var node))
1296 (val (child1 node)))
1297 (varset-union
1298 (varset-singleton var)
1299 (fv val))))
1300 ((if? node)
1301 (let ((a (list-ref (node-children node) 0))
1302 (b (list-ref (node-children node) 1))
1303 (c (list-ref (node-children node) 2)))
1304 (varset-union-multi (list (fv a) (fv b) (fv c)))))
1305 ((prc? node)
1306 (let ((body (list-ref (node-children node) 0)))
1307 (varset-difference
1308 (fv body)
1309 (build-params-varset (prc-params node)))))
1310 ((call? node)
1311 (varset-union-multi (map fv (node-children node))))
1312 ((seq? node)
1313 (varset-union-multi (map fv (node-children node))))
1314 (else
1315 (compiler-error "unknown expression type" node)))))
1317 (define build-params-varset
1318 (lambda (params)
1319 (list->varset params)))
1321 (define mark-needed-global-vars!
1322 (lambda (global-env node)
1324 (define readyq
1325 (env-lookup global-env '#%readyq))
1327 (define mark-var!
1328 (lambda (var)
1329 (if (and (var-global? var)
1330 (not (var-needed? var))
1331 ;; globals that obey the following conditions are considered
1332 ;; to be constants
1333 (not (and (not (mutable-var? var))
1334 (> (length (var-defs var)) 0) ;; TODO to catch errors for primitives
1335 (cst? (child1 (car (var-defs var)))))))
1336 (begin
1337 (var-needed?-set! var #t)
1338 (for-each
1339 (lambda (def)
1340 (let ((val (child1 def)))
1341 (if (side-effect-less? val)
1342 (mark! val))))
1343 (var-defs var))
1344 (if (eq? var readyq)
1345 (begin
1346 (mark-var!
1347 (env-lookup global-env '#%start-first-process))
1348 (mark-var!
1349 (env-lookup global-env '#%exit))))))))
1351 (define side-effect-less?
1352 (lambda (node)
1353 (or (cst? node)
1354 (ref? node)
1355 (prc? node))))
1357 (define mark!
1358 (lambda (node)
1359 (cond ((cst? node))
1360 ((ref? node)
1361 (let ((var (ref-var node)))
1362 (mark-var! var)))
1363 ((def? node)
1364 (let ((var (def-var node))
1365 (val (child1 node)))
1366 (if (not (side-effect-less? val))
1367 (mark! val))))
1368 ((set? node)
1369 (let ((var (set-var node))
1370 (val (child1 node)))
1371 (mark! val)))
1372 ((if? node)
1373 (let ((a (list-ref (node-children node) 0))
1374 (b (list-ref (node-children node) 1))
1375 (c (list-ref (node-children node) 2)))
1376 (mark! a)
1377 (mark! b)
1378 (mark! c)))
1379 ((prc? node)
1380 (let ((body (list-ref (node-children node) 0)))
1381 (mark! body)))
1382 ((call? node)
1383 (for-each mark! (node-children node)))
1384 ((seq? node)
1385 (for-each mark! (node-children node)))
1386 (else
1387 (compiler-error "unknown expression type" node)))))
1389 (mark! node)
1390 ))
1392 ;-----------------------------------------------------------------------------
1394 ;; Variable sets
1396 (define (varset-empty) ; return the empty set
1397 '())
1399 (define (varset-singleton x) ; create a set containing only 'x'
1400 (list x))
1402 (define (list->varset lst) ; convert list to set
1403 lst)
1405 (define (varset->list set) ; convert set to list
1406 set)
1408 (define (varset-size set) ; return cardinality of set
1409 (list-length set))
1411 (define (varset-empty? set) ; is 'x' the empty set?
1412 (null? set))
1414 (define (varset-member? x set) ; is 'x' a member of the 'set'?
1415 (and (not (null? set))
1416 (or (eq? x (car set))
1417 (varset-member? x (cdr set)))))
1419 (define (varset-adjoin set x) ; add the element 'x' to the 'set'
1420 (if (varset-member? x set) set (cons x set)))
1422 (define (varset-remove set x) ; remove the element 'x' from 'set'
1423 (cond ((null? set)
1424 '())
1425 ((eq? (car set) x)
1426 (cdr set))
1427 (else
1428 (cons (car set) (varset-remove (cdr set) x)))))
1430 (define (varset-equal? s1 s2) ; are 's1' and 's2' equal sets?
1431 (and (varset-subset? s1 s2)
1432 (varset-subset? s2 s1)))
1434 (define (varset-subset? s1 s2) ; is 's1' a subset of 's2'?
1435 (cond ((null? s1)
1436 #t)
1437 ((varset-member? (car s1) s2)
1438 (varset-subset? (cdr s1) s2))
1439 (else
1440 #f)))
1442 (define (varset-difference set1 set2) ; return difference of sets
1443 (cond ((null? set1)
1444 '())
1445 ((varset-member? (car set1) set2)
1446 (varset-difference (cdr set1) set2))
1447 (else
1448 (cons (car set1) (varset-difference (cdr set1) set2)))))
1450 (define (varset-union set1 set2) ; return union of sets
1451 (define (union s1 s2)
1452 (cond ((null? s1)
1453 s2)
1454 ((varset-member? (car s1) s2)
1455 (union (cdr s1) s2))
1456 (else
1457 (cons (car s1) (union (cdr s1) s2)))))
1458 (if (varset-smaller? set1 set2)
1459 (union set1 set2)
1460 (union set2 set1)))
1462 (define (varset-intersection set1 set2) ; return intersection of sets
1463 (define (intersection s1 s2)
1464 (cond ((null? s1)
1465 '())
1466 ((varset-member? (car s1) s2)
1467 (cons (car s1) (intersection (cdr s1) s2)))
1468 (else
1469 (intersection (cdr s1) s2))))
1470 (if (varset-smaller? set1 set2)
1471 (intersection set1 set2)
1472 (intersection set2 set1)))
1474 (define (varset-intersects? set1 set2) ; do sets 'set1' and 'set2' intersect?
1475 (not (varset-empty? (varset-intersection set1 set2))))
1477 (define (varset-smaller? set1 set2)
1478 (if (null? set1)
1479 (not (null? set2))
1480 (if (null? set2)
1481 #f
1482 (varset-smaller? (cdr set1) (cdr set2)))))
1484 (define (varset-union-multi sets)
1485 (if (null? sets)
1486 (varset-empty)
1487 (n-ary varset-union (car sets) (cdr sets))))
1489 (define (n-ary function first rest)
1490 (if (null? rest)
1491 first
1492 (n-ary function (function first (car rest)) (cdr rest))))
1494 ;------------------------------------------------------------------------------
1496 (define code->vector
1497 (lambda (code)
1498 (let ((v (make-vector (+ (code-last-label code) 1))))
1499 (for-each
1500 (lambda (bb)
1501 (vector-set! v (bb-label bb) bb))
1502 (code-rev-bbs code))
1503 v)))
1505 (define bbs->ref-counts
1506 (lambda (bbs)
1507 (let ((ref-counts (make-vector (vector-length bbs) 0)))
1509 (define visit
1510 (lambda (label)
1511 (let ((ref-count (vector-ref ref-counts label)))
1512 (vector-set! ref-counts label (+ ref-count 1))
1513 (if (= ref-count 0)
1514 (let* ((bb (vector-ref bbs label))
1515 (rev-instrs (bb-rev-instrs bb)))
1516 (for-each
1517 (lambda (instr)
1518 (let ((opcode (car instr)))
1519 (cond ((eq? opcode 'goto)
1520 (visit (cadr instr)))
1521 ((eq? opcode 'goto-if-false)
1522 (visit (cadr instr))
1523 (visit (caddr instr)))
1524 ((or (eq? opcode 'closure)
1525 (eq? opcode 'call-toplevel)
1526 (eq? opcode 'jump-toplevel))
1527 (visit (cadr instr))))))
1528 rev-instrs))))))
1530 (visit 0)
1532 ref-counts)))
1534 (define resolve-toplevel-labels!
1535 (lambda (bbs)
1536 (let loop ((i 0))
1537 (if (< i (vector-length bbs))
1538 (let* ((bb (vector-ref bbs i))
1539 (rev-instrs (bb-rev-instrs bb)))
1540 (bb-rev-instrs-set!
1541 bb
1542 (map (lambda (instr)
1543 (let ((opcode (car instr)))
1544 (cond ((eq? opcode 'call-toplevel)
1545 (list opcode
1546 (prc-entry-label (cadr instr))))
1547 ((eq? opcode 'jump-toplevel)
1548 (list opcode
1549 (prc-entry-label (cadr instr))))
1550 (else
1551 instr))))
1552 rev-instrs))
1553 (loop (+ i 1)))))))
1555 (define tighten-jump-cascades!
1556 (lambda (bbs)
1557 (let ((ref-counts (bbs->ref-counts bbs)))
1559 (define resolve
1560 (lambda (label)
1561 (let* ((bb (vector-ref bbs label))
1562 (rev-instrs (bb-rev-instrs bb)))
1563 (and (or (null? (cdr rev-instrs))
1564 (= (vector-ref ref-counts label) 1))
1565 rev-instrs))))
1567 (let loop1 ()
1568 (let loop2 ((i 0)
1569 (changed? #f))
1570 (if (< i (vector-length bbs))
1571 (if (> (vector-ref ref-counts i) 0)
1572 (let* ((bb (vector-ref bbs i))
1573 (rev-instrs (bb-rev-instrs bb))
1574 (jump (car rev-instrs))
1575 (opcode (car jump)))
1576 (cond ((eq? opcode 'goto)
1577 (let* ((label (cadr jump))
1578 (jump-replacement (resolve label)))
1579 (if jump-replacement
1580 (begin
1581 (vector-set!
1582 bbs
1583 i
1584 (make-bb (bb-label bb)
1585 (append jump-replacement
1586 (cdr rev-instrs))))
1587 (loop2 (+ i 1)
1588 #t))
1589 (loop2 (+ i 1)
1590 changed?))))
1591 ((eq? opcode 'goto-if-false)
1592 (let* ((label-then (cadr jump))
1593 (label-else (caddr jump))
1594 (jump-then-replacement (resolve label-then))
1595 (jump-else-replacement (resolve label-else)))
1596 (if (and jump-then-replacement
1597 (null? (cdr jump-then-replacement))
1598 jump-else-replacement
1599 (null? (cdr jump-else-replacement))
1600 (or (eq? (caar jump-then-replacement) 'goto)
1601 (eq? (caar jump-else-replacement) 'goto)))
1602 (begin
1603 (vector-set!
1604 bbs
1605 i
1606 (make-bb (bb-label bb)
1607 (cons (list 'goto-if-false
1608 (if (eq? (caar jump-then-replacement) 'goto)
1609 (cadar jump-then-replacement)
1610 label-then)
1611 (if (eq? (caar jump-else-replacement) 'goto)
1612 (cadar jump-else-replacement)
1613 label-else))
1614 (cdr rev-instrs))))
1615 (loop2 (+ i 1)
1616 #t))
1617 (loop2 (+ i 1)
1618 changed?))))
1619 (else
1620 (loop2 (+ i 1)
1621 changed?))))
1622 (loop2 (+ i 1)
1623 changed?))
1624 (if changed?
1625 (loop1))))))))
1627 (define remove-useless-bbs!
1628 (lambda (bbs)
1629 (let ((ref-counts (bbs->ref-counts bbs)))
1630 (let loop1 ((label 0) (new-label 0))
1631 (if (< label (vector-length bbs))
1632 (if (> (vector-ref ref-counts label) 0)
1633 (let ((bb (vector-ref bbs label)))
1634 (vector-set!
1635 bbs
1636 label
1637 (make-bb new-label (bb-rev-instrs bb)))
1638 (loop1 (+ label 1) (+ new-label 1)))
1639 (loop1 (+ label 1) new-label))
1640 (renumber-labels bbs ref-counts new-label))))))
1642 (define renumber-labels
1643 (lambda (bbs ref-counts n)
1644 (let ((new-bbs (make-vector n)))
1645 (let loop2 ((label 0))
1646 (if (< label (vector-length bbs))
1647 (if (> (vector-ref ref-counts label) 0)
1648 (let* ((bb (vector-ref bbs label))
1649 (new-label (bb-label bb))
1650 (rev-instrs (bb-rev-instrs bb)))
1652 (define fix
1653 (lambda (instr)
1655 (define new-label
1656 (lambda (label)
1657 (bb-label (vector-ref bbs label))))
1659 (let ((opcode (car instr)))
1660 (cond ((eq? opcode 'closure)
1661 (list 'closure
1662 (new-label (cadr instr))))
1663 ((eq? opcode 'call-toplevel)
1664 (list 'call-toplevel
1665 (new-label (cadr instr))))
1666 ((eq? opcode 'jump-toplevel)
1667 (list 'jump-toplevel
1668 (new-label (cadr instr))))
1669 ((eq? opcode 'goto)
1670 (list 'goto
1671 (new-label (cadr instr))))
1672 ((eq? opcode 'goto-if-false)
1673 (list 'goto-if-false
1674 (new-label (cadr instr))
1675 (new-label (caddr instr))))
1676 (else
1677 instr)))))
1679 (vector-set!
1680 new-bbs
1681 new-label
1682 (make-bb new-label (map fix rev-instrs)))
1683 (loop2 (+ label 1)))
1684 (loop2 (+ label 1)))
1685 new-bbs)))))
1687 (define reorder!
1688 (lambda (bbs)
1689 (let* ((done (make-vector (vector-length bbs) #f)))
1691 (define unscheduled?
1692 (lambda (label)
1693 (not (vector-ref done label))))
1695 (define label-refs
1696 (lambda (instrs todo)
1697 (if (pair? instrs)
1698 (let* ((instr (car instrs))
1699 (opcode (car instr)))
1700 (cond ((or (eq? opcode 'closure)
1701 (eq? opcode 'call-toplevel)
1702 (eq? opcode 'jump-toplevel))
1703 (label-refs (cdr instrs) (cons (cadr instr) todo)))
1704 (else
1705 (label-refs (cdr instrs) todo))))
1706 todo)))
1708 (define schedule-here
1709 (lambda (label new-label todo cont)
1710 (let* ((bb (vector-ref bbs label))
1711 (rev-instrs (bb-rev-instrs bb))
1712 (jump (car rev-instrs))
1713 (opcode (car jump))
1714 (new-todo (label-refs rev-instrs todo)))
1715 (vector-set! bbs label (make-bb new-label rev-instrs))
1716 (vector-set! done label #t)
1717 (cond ((eq? opcode 'goto)
1718 (let ((label (cadr jump)))
1719 (if (unscheduled? label)
1720 (schedule-here label
1721 (+ new-label 1)
1722 new-todo
1723 cont)
1724 (cont (+ new-label 1)
1725 new-todo))))
1726 ((eq? opcode 'goto-if-false)
1727 (let ((label-then (cadr jump))
1728 (label-else (caddr jump)))
1729 (cond ((unscheduled? label-else)
1730 (schedule-here label-else
1731 (+ new-label 1)
1732 (cons label-then new-todo)
1733 cont))
1734 ((unscheduled? label-then)
1735 (schedule-here label-then
1736 (+ new-label 1)
1737 new-todo
1738 cont))
1739 (else
1740 (cont (+ new-label 1)
1741 new-todo)))))
1742 (else
1743 (cont (+ new-label 1)
1744 new-todo))))))
1746 (define schedule-somewhere
1747 (lambda (label new-label todo cont)
1748 (schedule-here label new-label todo cont)))
1750 (define schedule-todo
1751 (lambda (new-label todo)
1752 (if (pair? todo)
1753 (let ((label (car todo)))
1754 (if (unscheduled? label)
1755 (schedule-somewhere label
1756 new-label
1757 (cdr todo)
1758 schedule-todo)
1759 (schedule-todo new-label
1760 (cdr todo)))))))
1763 (schedule-here 0 0 '() schedule-todo)
1765 (renumber-labels bbs
1766 (make-vector (vector-length bbs) 1)
1767 (vector-length bbs)))))
1769 (define linearize
1770 (lambda (bbs)
1771 (let loop ((label (- (vector-length bbs) 1))
1772 (lst '()))
1773 (if (>= label 0)
1774 (let* ((bb (vector-ref bbs label))
1775 (rev-instrs (bb-rev-instrs bb))
1776 (jump (car rev-instrs))
1777 (opcode (car jump)))
1778 (loop (- label 1)
1779 (append
1780 (list label)
1781 (reverse
1782 (cond ((eq? opcode 'goto)
1783 (if (= (cadr jump) (+ label 1))
1784 (cdr rev-instrs)
1785 rev-instrs))
1786 ((eq? opcode 'goto-if-false)
1787 (cond ((= (caddr jump) (+ label 1))
1788 (cons (list 'goto-if-false (cadr jump))
1789 (cdr rev-instrs)))
1790 ((= (cadr jump) (+ label 1))
1791 (cons (list 'goto-if-not-false (caddr jump))
1792 (cdr rev-instrs)))
1793 (else
1794 (cons (list 'goto (caddr jump))
1795 (cons (list 'goto-if-false (cadr jump))
1796 (cdr rev-instrs))))))
1797 (else
1798 rev-instrs)))
1799 lst)))
1800 lst))))
1802 (define optimize-code
1803 (lambda (code)
1804 (let ((bbs (code->vector code)))
1805 (resolve-toplevel-labels! bbs)
1806 (tighten-jump-cascades! bbs)
1807 (let ((bbs (remove-useless-bbs! bbs)))
1808 (reorder! bbs)))))
1811 (define expand-loads
1812 (lambda (exprs)
1813 (map (lambda (e)
1814 (if (eq? (car e) 'load)
1815 (cons 'begin
1816 (expand-loads (with-input-from-file (cadr e) read-all)))
1817 e))
1818 exprs)))
1820 (define parse-file
1821 (lambda (filename)
1822 (let* ((library
1823 (with-input-from-file "library.scm" read-all))
1824 (toplevel-exprs
1825 (expand-loads (append library
1826 (with-input-from-file filename read-all))))
1827 (global-env
1828 (make-global-env))
1829 (parsed-prog
1830 (parse-top (cons 'begin toplevel-exprs) global-env)))
1832 (for-each
1833 (lambda (node)
1834 (mark-needed-global-vars! global-env node))
1835 parsed-prog)
1837 (extract-parts
1838 parsed-prog
1839 (lambda (defs after-defs)
1841 (define make-seq-preparsed
1842 (lambda (exprs)
1843 (let ((r (make-seq #f exprs)))
1844 (for-each (lambda (x) (node-parent-set! x r)) exprs)
1845 r)))
1847 (define make-call-preparsed
1848 (lambda (exprs)
1849 (let ((r (make-call #f exprs)))
1850 (for-each (lambda (x) (node-parent-set! x r)) exprs)
1851 r)))
1853 (if (var-needed?
1854 (env-lookup global-env '#%readyq))
1855 (make-seq-preparsed
1856 (list (make-seq-preparsed defs)
1857 (make-call-preparsed
1858 (list (parse 'value '#%start-first-process global-env)
1859 (let* ((pattern
1860 '())
1861 (ids
1862 (extract-ids pattern))
1863 (r
1864 (make-prc #f '() #f (has-rest-param? pattern) #f))
1865 (new-env
1866 (env-extend global-env ids r))
1867 (body
1868 (make-seq-preparsed after-defs)))
1869 (prc-params-set!
1870 r
1871 (map (lambda (id) (env-lookup new-env id))
1872 ids))
1873 (node-children-set! r (list body))
1874 (node-parent-set! body r)
1875 r)))
1876 (parse 'value
1877 '(#%exit)
1878 global-env)))
1879 (make-seq-preparsed
1880 (append defs
1881 after-defs
1882 (list (parse 'value
1883 '(#%halt)
1884 global-env))))))))))
1886 (define extract-parts
1887 (lambda (lst cont)
1888 (if (or (null? lst)
1889 (not (def? (car lst))))
1890 (cont '() lst)
1891 (extract-parts
1892 (cdr lst)
1893 (lambda (d ad)
1894 (cont (cons (car lst) d) ad))))))
1896 ;------------------------------------------------------------------------------
1898 ;;(include "asm.scm")
1900 ;;; File: "asm.scm"
1901 ;;;
1902 ;;; This module implements the generic assembler.
1904 ;;(##declare (standard-bindings) (fixnum) (block))
1906 (define compiler-internal-error error)
1908 ;; (asm-begin! start-pos big-endian?) initializes the assembler and
1909 ;; starts a new empty code stream at address "start-pos". It must be
1910 ;; called every time a new code stream is to be built. The argument
1911 ;; "big-endian?" indicates the byte ordering to use for 16, 32 and 64
1912 ;; bit values. After a call to "asm-begin!" the code stream is built
1913 ;; by calling the following procedures:
1914 ;;
1915 ;; asm-8 to add an 8 bit integer to the code stream
1916 ;; asm-16 to add a 16 bit integer to the code stream
1917 ;; asm-32 to add a 32 bit integer to the code stream
1918 ;; asm-64 to add a 64 bit integer to the code stream
1919 ;; asm-float64 to add a 64 bit IEEE float to the code stream
1920 ;; asm-string to add a null terminated string to the code stream
1921 ;; asm-label to set a label to the current position in the code stream
1922 ;; asm-align to add enough zero bytes to force alignment
1923 ;; asm-origin to add enough zero bytes to move to a particular address
1924 ;; asm-at-assembly to defer code production to assembly time
1925 ;; asm-listing to add textual information to the listing
1927 (define (asm-begin! start-pos big-endian?)
1928 (set! asm-start-pos start-pos)
1929 (set! asm-big-endian? big-endian?)
1930 (set! asm-code-stream (asm-make-stream))
1931 #f)
1933 ;; (asm-end!) must be called to finalize the assembler.
1935 (define (asm-end!)
1936 (set! asm-code-stream #f)
1937 #f)
1939 ;; (asm-8 n) adds an 8 bit signed or unsigned integer to the code stream.
1941 (define (asm-8 n)
1942 (asm-code-extend (asm-bits-0-to-7 n)))
1944 ;; (asm-16 n) adds a 16 bit signed or unsigned integer to the code stream.
1946 (define (asm-16 n)
1947 (if asm-big-endian?
1948 (begin (asm-8 (asm-bits-8-and-up n)) (asm-8 n))
1949 (begin (asm-8 n) (asm-8 (asm-bits-8-and-up n)))))
1951 ;; (asm-32 n) adds a 32 bit signed or unsigned integer to the code stream.
1953 (define (asm-32 n)
1954 (if asm-big-endian?
1955 (begin (asm-16 (asm-bits-16-and-up n)) (asm-16 n))
1956 (begin (asm-16 n) (asm-16 (asm-bits-16-and-up n)))))
1958 ;; (asm-64 n) adds a 64 bit signed or unsigned integer to the code stream.
1960 (define (asm-64 n)
1961 (if asm-big-endian?
1962 (begin (asm-32 (asm-bits-32-and-up n)) (asm-32 n))
1963 (begin (asm-32 n) (asm-32 (asm-bits-32-and-up n)))))
1965 ;; (asm-float64 n) adds a 64 bit IEEE floating point number to the code stream.
1967 (define (asm-float64 n)
1968 (asm-64 (asm-float->bits n)))
1970 ;; (asm-string str) adds a null terminated string to the code stream.
1972 (define (asm-string str)
1973 (let ((len (string-length str)))
1974 (let loop ((i 0))
1975 (if (< i len)
1976 (begin
1977 (asm-8 (char->integer (string-ref str i)))
1978 (loop (+ i 1)))
1979 (asm-8 0)))))
1981 ;; (asm-make-label id) creates a new label object. A label can
1982 ;; be queried with "asm-label-pos" to obtain the label's position
1983 ;; relative to the start of the code stream (i.e. "start-pos").
1984 ;; The argument "id" gives a name to the label (not necessarily
1985 ;; unique) and is only needed for debugging purposes.
1987 (define (asm-make-label id)
1988 (vector 'LABEL #f id))
1990 ;; (asm-label label-obj) sets the label to the current position in the
1991 ;; code stream.
1993 (define (asm-label label-obj)
1994 (if (vector-ref label-obj 1)
1995 (compiler-internal-error
1996 "asm-label, label multiply defined" (asm-label-id label-obj))
1997 (begin
1998 (vector-set! label-obj 1 0)
1999 (asm-code-extend label-obj))))
2001 ;; (asm-label-id label-obj) returns the identifier of the label object.
2003 (define (asm-label-id label-obj)
2004 (vector-ref label-obj 2))
2006 ;; (asm-label-pos label-obj) returns the position of the label
2007 ;; relative to the start of the code stream (i.e. "start-pos").
2008 ;; This procedure can only be called at assembly time (i.e.
2009 ;; within the call to "asm-assemble") or after assembly time
2010 ;; for labels declared prior to assembly time with "asm-label".
2011 ;; A label declared at assembly time can only be queried after
2012 ;; assembly time. Moreover, at assembly time the position of a
2013 ;; label may vary from one call to the next due to the actions
2014 ;; of the assembler.
2016 (define (asm-label-pos label-obj)
2017 (let ((pos (vector-ref label-obj 1)))
2018 (if pos
2019 pos
2020 (compiler-internal-error
2021 "asm-label-pos, undefined label" (asm-label-id label-obj)))))
2023 ;; (asm-align multiple offset) adds enough zero bytes to the code
2024 ;; stream to force alignment to the next address congruent to
2025 ;; "offset" modulo "multiple".
2027 (define (asm-align multiple offset)
2028 (asm-at-assembly
2029 (lambda (self)
2030 (modulo (- multiple (- self offset)) multiple))
2031 (lambda (self)
2032 (let loop ((n (modulo (- multiple (- self offset)) multiple)))
2033 (if (> n 0)
2034 (begin
2035 (asm-8 0)
2036 (loop (- n 1))))))))
2038 ;; (asm-origin address) adds enough zero bytes to the code stream to move
2039 ;; to the address "address".
2041 (define (asm-origin address)
2042 (asm-at-assembly
2043 (lambda (self)
2044 (- address self))
2045 (lambda (self)
2046 (let ((len (- address self)))
2047 (if (< len 0)
2048 (compiler-internal-error "asm-origin, can't move back")
2049 (let loop ((n len))
2050 (if (> n 0)
2051 (begin
2052 (asm-8 0)
2053 (loop (- n 1))))))))))
2055 ;; (asm-at-assembly . procs) makes it possible to defer code
2056 ;; production to assembly time. A useful application is to generate
2057 ;; position dependent and span dependent code sequences. This
2058 ;; procedure must be passed an even number of procedures. All odd
2059 ;; indexed procedures (including the first procedure) are called "check"
2060 ;; procedures. The even indexed procedures are the "production"
2061 ;; procedures which, when called, produce a particular code sequence.
2062 ;; A check procedure decides if, given the current state of assembly
2063 ;; (in particular the current positioning of the labels), the code
2064 ;; produced by the corresponding production procedure is valid.
2065 ;; If the code is not valid, the check procedure must return #f.
2066 ;; If the code is valid, the check procedure must return the length
2067 ;; of the code sequence in bytes. The assembler will try each check
2068 ;; procedure in order until it finds one that does not return #f
2069 ;; (the last check procedure must never return #f). For convenience,
2070 ;; the current position in the code sequence is passed as the single
2071 ;; argument of check and production procedures.
2072 ;;
2073 ;; Here is a sample call of "asm-at-assembly" to produce the
2074 ;; shortest branch instruction to branch to label "x" for a
2075 ;; hypothetical processor:
2076 ;;
2077 ;; (asm-at-assembly
2078 ;;
2079 ;; (lambda (self) ; first check procedure
2080 ;; (let ((dist (- (asm-label-pos x) self)))
2081 ;; (if (and (>= dist -128) (<= dist 127)) ; short branch possible?
2082 ;; 2
2083 ;; #f)))
2084 ;;
2085 ;; (lambda (self) ; first production procedure
2086 ;; (asm-8 #x34) ; branch opcode for 8 bit displacement
2087 ;; (asm-8 (- (asm-label-pos x) self)))
2088 ;;
2089 ;; (lambda (self) 5) ; second check procedure
2090 ;;
2091 ;; (lambda (self) ; second production procedure
2092 ;; (asm-8 #x35) ; branch opcode for 32 bit displacement
2093 ;; (asm-32 (- (asm-label-pos x) self))))
2095 (define (asm-at-assembly . procs)
2096 (asm-code-extend (vector 'DEFERRED procs)))
2098 ;; (asm-listing text) adds text to the right side of the listing.
2099 ;; The atoms in "text" will be output using "display" (lists are
2100 ;; traversed recursively). The listing is generated by calling
2101 ;; "asm-display-listing".
2103 (define (asm-listing text)
2104 (asm-code-extend (vector 'LISTING text)))
2106 ;; (asm-assemble) assembles the code stream. After assembly, the
2107 ;; label objects will be set to their final position and the
2108 ;; alignment bytes and the deferred code will have been produced. It
2109 ;; is possible to extend the code stream after assembly. However, if
2110 ;; any of the procedures "asm-label", "asm-align", and
2111 ;; "asm-at-assembly" are called, the code stream will have to be
2112 ;; assembled once more.
2114 (define (asm-assemble)
2115 (let ((fixup-lst (asm-pass1)))
2117 (let loop1 ()
2118 (let loop2 ((lst fixup-lst)
2119 (changed? #f)
2120 (pos asm-start-pos))
2121 (if (null? lst)
2122 (if changed? (loop1))
2123 (let* ((fixup (car lst))
2124 (pos (+ pos (car fixup)))
2125 (curr (cdr fixup))
2126 (x (car curr)))
2127 (if (eq? (vector-ref x 0) 'LABEL)
2128 ; LABEL
2129 (if (= (vector-ref x 1) pos)
2130 (loop2 (cdr lst) changed? pos)
2131 (begin
2132 (vector-set! x 1 pos)
2133 (loop2 (cdr lst) #t pos)))
2134 ; DEFERRED
2135 (let loop3 ()
2136 (let ((n ((car (vector-ref x 1)) pos)))
2137 (if n
2138 (loop2 (cdr lst) changed? (+ pos n))
2139 (begin
2140 (vector-set! x 1 (cddr (vector-ref x 1)))
2141 (loop3))))))))))
2143 (let loop4 ((prev asm-code-stream)
2144 (curr (cdr asm-code-stream))
2145 (pos asm-start-pos))
2146 (if (null? curr)
2147 (set-car! asm-code-stream prev)
2148 (let ((x (car curr))
2149 (next (cdr curr)))
2150 (if (vector? x)
2151 (let ((kind (vector-ref x 0)))
2152 (cond ((eq? kind 'LABEL)
2153 (let ((final-pos (vector-ref x 1)))
2154 (if final-pos
2155 (if (not (= pos final-pos))
2156 (compiler-internal-error
2157 "asm-assemble, inconsistency detected"))
2158 (vector-set! x 1 pos))
2159 (set-cdr! prev next)
2160 (loop4 prev next pos)))
2161 ((eq? kind 'DEFERRED)
2162 (let ((temp asm-code-stream))
2163 (set! asm-code-stream (asm-make-stream))
2164 ((cadr (vector-ref x 1)) pos)
2165 (let ((tail (car asm-code-stream)))
2166 (set-cdr! tail next)
2167 (let ((head (cdr asm-code-stream)))
2168 (set-cdr! prev head)
2169 (set! asm-code-stream temp)
2170 (loop4 prev head pos)))))
2171 (else
2172 (loop4 curr next pos))))
2173 (loop4 curr next (+ pos 1))))))))
2175 ;; (asm-display-listing port) produces a listing of the code stream
2176 ;; on the given output port. The bytes generated are shown in
2177 ;; hexadecimal on the left side of the listing and the right side
2178 ;; of the listing contains the text inserted by "asm-listing".
2180 (define (asm-display-listing port)
2182 (define text-col 24)
2183 (define pos-width 6)
2184 (define byte-width 2)
2186 (define (output text)
2187 (cond ((null? text))
2188 ((pair? text)
2189 (output (car text))
2190 (output (cdr text)))
2191 (else
2192 (display text port))))
2194 (define (print-hex n)
2195 (display (string-ref "0123456789ABCDEF" n) port))
2197 (define (print-byte n)
2198 (print-hex (quotient n 16))
2199 (print-hex (modulo n 16)))
2201 (define (print-pos n)
2202 (if (< n 0)
2203 (display " " port)
2204 (begin
2205 (print-byte (quotient n #x10000))
2206 (print-byte (modulo (quotient n #x100) #x100))
2207 (print-byte (modulo n #x100)))))
2209 (let loop1 ((lst (cdr asm-code-stream)) (pos asm-start-pos) (col 0))
2210 (if (null? lst)
2211 (if (> col 0)
2212 (newline port))
2213 (let ((x (car lst)))
2214 (if (vector? x)
2215 (let ((kind (vector-ref x 0)))
2216 (cond ((eq? kind 'LISTING)
2217 (let loop2 ((col col))
2218 (if (< col text-col)
2219 (begin
2220 (display (integer->char 9) port)
2221 (loop2 (* 8 (+ (quotient col 8) 1))))))
2222 (output (vector-ref x 1))
2223 (newline port)
2224 (loop1 (cdr lst) pos 0))
2225 (else
2226 (compiler-internal-error
2227 "asm-display-listing, code stream not assembled"))))
2228 (if (or (= col 0) (>= col (- text-col byte-width)))
2229 (begin
2230 (if (not (= col 0)) (newline port))
2231 (print-pos pos)
2232 (display " " port)
2233 (print-byte x)
2234 (loop1 (cdr lst) (+ pos 1) (+ (+ pos-width 1) byte-width)))
2235 (begin
2236 (print-byte x)
2237 (loop1 (cdr lst) (+ pos 1) (+ col byte-width)))))))))
2239 ;; (asm-write-code filename) outputs the code stream (i.e. the sequence
2240 ;; of bytes produced) on the named file.
2242 (define (asm-write-code filename)
2243 (with-output-to-file filename
2244 (lambda ()
2245 (let loop ((lst (cdr asm-code-stream)))
2246 (if (not (null? lst))
2247 (let ((x (car lst)))
2248 (if (vector? x)
2249 (let ((kind (vector-ref x 0)))
2250 (if (not (eq? kind 'LISTING))
2251 (compiler-internal-error
2252 "asm-write-code, code stream not assembled"))
2253 (loop (cdr lst)))
2254 (begin
2255 (write-char (integer->char x))
2256 (loop (cdr lst))))))))))
2258 (define (asm-write-hex-file filename)
2259 (with-output-to-file filename
2260 (lambda ()
2262 (define (print-hex n)
2263 (display (string-ref "0123456789ABCDEF" n)))
2265 (define (print-byte n)
2266 (print-hex (quotient n 16))
2267 (print-hex (modulo n 16)))
2269 (define (print-line type addr bytes)
2270 (let ((n (length bytes))
2271 (addr-hi (quotient addr 256))
2272 (addr-lo (modulo addr 256)))
2273 (display ":")
2274 (print-byte n)
2275 (print-byte addr-hi)
2276 (print-byte addr-lo)
2277 (print-byte type)
2278 (for-each print-byte bytes)
2279 (let ((sum
2280 (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
2281 (print-byte sum)
2282 (newline))))
2284 (let loop ((lst (cdr asm-code-stream))
2285 (pos asm-start-pos)
2286 (rev-bytes '()))
2287 (if (not (null? lst))
2288 (let ((x (car lst)))
2289 (if (vector? x)
2290 (let ((kind (vector-ref x 0)))
2291 (if (not (eq? kind 'LISTING))
2292 (compiler-internal-error
2293 "asm-write-hex-file, code stream not assembled"))
2294 (loop (cdr lst)
2295 pos
2296 rev-bytes))
2297 (let ((new-pos
2298 (+ pos 1))
2299 (new-rev-bytes
2300 (cons x
2301 (if (= (modulo pos 16) 0)
2302 (begin
2303 (print-line 0
2304 (- pos (length rev-bytes))
2305 (reverse rev-bytes))
2306 '())
2307 rev-bytes))))
2308 (loop (cdr lst)
2309 new-pos
2310 new-rev-bytes))))
2311 (begin
2312 (if (not (null? rev-bytes))
2313 (print-line 0
2314 (- pos (length rev-bytes))
2315 (reverse rev-bytes)))
2316 (print-line 1 0 '())
2317 (if #t
2318 (begin
2319 (display (- pos asm-start-pos) ##stderr-port)
2320 (display " bytes\n" ##stderr-port)))))))))
2322 ;; Utilities.
2324 (define asm-start-pos #f) ; start position of the code stream
2325 (define asm-big-endian? #f) ; endianness to use
2326 (define asm-code-stream #f) ; current code stream
2328 (define (asm-make-stream) ; create an empty stream
2329 (let ((x (cons '() '())))
2330 (set-car! x x)
2331 x))
2333 (define (asm-code-extend item) ; add an item at the end of current code stream
2334 (let* ((stream asm-code-stream)
2335 (tail (car stream))
2336 (cell (cons item '())))
2337 (set-cdr! tail cell)
2338 (set-car! stream cell)))
2340 (define (asm-pass1) ; construct fixup list and make first label assignment
2341 (let loop ((curr (cdr asm-code-stream))
2342 (fixup-lst '())
2343 (span 0)
2344 (pos asm-start-pos))
2345 (if (null? curr)
2346 (reverse fixup-lst)
2347 (let ((x (car curr)))
2348 (if (vector? x)
2349 (let ((kind (vector-ref x 0)))
2350 (cond ((eq? kind 'LABEL)
2351 (vector-set! x 1 pos) ; first approximation of position
2352 (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
2353 ((eq? kind 'DEFERRED)
2354 (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
2355 (else
2356 (loop (cdr curr) fixup-lst span pos))))
2357 (loop (cdr curr) fixup-lst (+ span 1) (+ pos 1)))))))
2359 ;(##declare (generic))
2361 (define (asm-bits-0-to-7 n) ; return bits 0 to 7 of a signed integer
2362 (modulo n #x100))
2364 (define (asm-bits-8-and-up n) ; return bits 8 and up of a signed integer
2365 (if (>= n 0)
2366 (quotient n #x100)
2367 (- (quotient (+ n 1) #x100) 1)))
2369 (define (asm-bits-16-and-up n) ; return bits 16 and up of a signed integer
2370 (if (>= n 0)
2371 (quotient n #x10000)
2372 (- (quotient (+ n 1) #x10000) 1)))
2374 (define (asm-bits-32-and-up n) ; return bits 32 and up of a signed integer
2375 (if (>= n 0)
2376 (quotient n #x100000000)
2377 (- (quotient (+ n 1) #x100000000) 1)))
2379 ; The following procedures convert floating point numbers into their
2380 ; machine representation. They perform bignum and flonum arithmetic.
2382 (define (asm-float->inexact-exponential-format x)
2384 (define (exp-form-pos x y i)
2385 (let ((i*2 (+ i i)))
2386 (let ((z (if (and (not (< asm-ieee-e-bias i*2))
2387 (not (< x y)))
2388 (exp-form-pos x (* y y) i*2)
2389 (cons x 0))))
2390 (let ((a (car z)) (b (cdr z)))
2391 (let ((i+b (+ i b)))
2392 (if (and (not (< asm-ieee-e-bias i+b))
2393 (not (< a y)))
2394 (begin
2395 (set-car! z (/ a y))
2396 (set-cdr! z i+b)))
2397 z)))))
2399 (define (exp-form-neg x y i)
2400 (let ((i*2 (+ i i)))
2401 (let ((z (if (and (< i*2 asm-ieee-e-bias-minus-1)
2402 (< x y))
2403 (exp-form-neg x (* y y) i*2)
2404 (cons x 0))))
2405 (let ((a (car z)) (b (cdr z)))
2406 (let ((i+b (+ i b)))
2407 (if (and (< i+b asm-ieee-e-bias-minus-1)
2408 (< a y))
2409 (begin
2410 (set-car! z (/ a y))
2411 (set-cdr! z i+b)))
2412 z)))))
2414 (define (exp-form x)
2415 (if (< x asm-inexact-+1)
2416 (let ((z (exp-form-neg x asm-inexact-+1/2 1)))
2417 (set-car! z (* asm-inexact-+2 (car z)))
2418 (set-cdr! z (- -1 (cdr z)))
2419 z)
2420 (exp-form-pos x asm-inexact-+2 1)))
2422 (if (negative? x)
2423 (let ((z (exp-form (- asm-inexact-0 x))))
2424 (set-car! z (- asm-inexact-0 (car z)))
2425 z)
2426 (exp-form x)))
2428 (define (asm-float->exact-exponential-format x)
2429 (let ((z (asm-float->inexact-exponential-format x)))
2430 (let ((y (car z)))
2431 (cond ((not (< y asm-inexact-+2))
2432 (set-car! z asm-ieee-+m-min)
2433 (set-cdr! z asm-ieee-e-bias-plus-1))
2434 ((not (< asm-inexact--2 y))
2435 (set-car! z asm-ieee--m-min)
2436 (set-cdr! z asm-ieee-e-bias-plus-1))
2437 (else
2438 (set-car! z
2439 (truncate (inexact->exact (* (car z) asm-inexact-m-min))))))
2440 (set-cdr! z (- (cdr z) asm-ieee-m-bits))
2441 z)))
2443 (define (asm-float->bits x) ; returns the 64 bit integer encoding the float "x"
2445 (define (bits a b)
2446 (if (< a asm-ieee-+m-min)
2447 a
2448 (+ (- a asm-ieee-+m-min)
2449 (* (+ (+ b asm-ieee-m-bits) asm-ieee-e-bias)
2450 asm-ieee-+m-min))))
2452 (let ((z (asm-float->exact-exponential-format x)))
2453 (let ((a (car z)) (b (cdr z)))
2454 (if (negative? a)
2455 (+ asm-ieee-sign-bit (bits (- 0 a) b))
2456 (bits a b)))))
2458 ; Parameters for ANSI-IEEE Std 754-1985 representation of
2459 ; doubles (i.e. 64 bit floating point numbers):
2461 (define asm-ieee-m-bits 52)
2462 (define asm-ieee-e-bits 11)
2463 (define asm-ieee-+m-min 4503599627370496) ; (expt 2 asm-ieee-m-bits)
2464 (define asm-ieee--m-min -4503599627370496) ; (- asm-ieee-+m-min)
2465 (define asm-ieee-sign-bit #x8000000000000000); (expt 2 (+ asm-ieee-e-bits asm-ieee-m-bits))
2467 (define asm-ieee-e-bias 1023) ; (- (expt 2 (- asm-ieee-e-bits 1)) 1)
2468 (define asm-ieee-e-bias-plus-1 1024) ; (+ asm-ieee-e-bias 1)
2469 (define asm-ieee-e-bias-minus-1 1022) ; (- asm-ieee-e-bias 1)
2471 (define asm-inexact-m-min (exact->inexact asm-ieee-+m-min))
2472 (define asm-inexact-+2 (exact->inexact 2))
2473 (define asm-inexact--2 (exact->inexact -2))
2474 (define asm-inexact-+1 (exact->inexact 1))
2475 (define asm-inexact-+1/2 (exact->inexact (/ 1 2)))
2476 (define asm-inexact-0 (exact->inexact 0))
2478 ;------------------------------------------------------------------------------
2480 (define min-fixnum-encoding 3)
2481 (define min-fixnum 0)
2482 (define max-fixnum 255)
2483 (define min-rom-encoding (+ min-fixnum-encoding (- max-fixnum min-fixnum) 1))
2484 (define min-ram-encoding 512)
2485 (define max-ram-encoding 4095)
2486 (define min-vec-encoding 4096)
2487 (define max-vec-encoding 8191)
2489 (define code-start #x5000)
2491 (define (predef-constants) (list))
2493 (define (predef-globals) (list))
2495 (define (encode-direct obj)
2496 (cond ((eq? obj #f)
2497 0)
2498 ((eq? obj #t)
2499 1)
2500 ((eq? obj '())
2501 2)
2502 ((and (integer? obj)
2503 (exact? obj)
2504 (>= obj min-fixnum)
2505 (<= obj max-fixnum))
2506 (+ obj (- min-fixnum-encoding min-fixnum)))
2507 (else
2508 #f)))
2510 (define (translate-constant obj)
2511 (if (char? obj)
2512 (char->integer obj)
2513 obj))
2515 (define (encode-constant obj constants)
2516 (let ((o (translate-constant obj)))
2517 (let ((e (encode-direct o)))
2518 (if e
2519 e
2520 (let ((x (assoc o constants))) ;; TODO was assq
2521 (if x
2522 (vector-ref (cdr x) 0)
2523 (compiler-error "unknown object" obj)))))))
2525 (define (add-constant obj constants from-code? cont)
2526 (let ((o (translate-constant obj)))
2527 (let ((e (encode-direct o)))
2528 (if e
2529 (cont constants)
2530 (let ((x (assoc o constants))) ;; TODO was assq
2531 (if x
2532 (begin
2533 (if from-code?
2534 (vector-set! (cdr x) 2 (+ (vector-ref (cdr x) 2) 1)))
2535 (cont constants))
2536 (let* ((descr
2537 (vector #f
2538 (asm-make-label 'constant)
2539 (if from-code? 1 0)
2540 #f))
2541 (new-constants
2542 (cons (cons o descr)
2543 constants)))
2544 (cond ((pair? o) ;; TODO what to do in the case of a pair of, for example, fixnums, where only one object is actually used ?
2545 (add-constants (list (car o) (cdr o))
2546 new-constants
2547 cont))
2548 ((symbol? o)
2549 (cont new-constants))
2550 ((string? o)
2551 (let ((chars (map char->integer (string->list o))))
2552 (vector-set! descr 3 chars)
2553 (add-constant chars
2554 new-constants
2555 #f
2556 cont)))
2557 ((vector? o)
2558 (let ((elems (vector->list o)))
2559 (vector-set! descr 3 elems)
2560 (add-constant elems
2561 new-constants
2562 #f
2563 cont)))
2564 ((u8vector? o) ;; NEW, for now they are lists
2565 (let ((elems (u8vector->list o)))
2566 (vector-set! descr 3 elems)
2567 (add-constant elems
2568 new-constants
2569 #f
2570 cont)))
2571 (else
2572 (cont new-constants))))))))))
2574 (define (add-constants objs constants cont)
2575 (if (null? objs)
2576 (cont constants)
2577 (add-constant (car objs)
2578 constants
2579 #f
2580 (lambda (new-constants)
2581 (add-constants (cdr objs)
2582 new-constants
2583 cont)))))
2585 (define (add-global var globals cont)
2586 (let ((x (assq var globals)))
2587 (if x
2588 (cont globals)
2589 (let ((new-globals
2590 (cons (cons var (length globals))
2591 globals)))
2592 (cont new-globals)))))
2594 (define (sort-constants constants)
2595 (let ((csts
2596 (sort-list constants
2597 (lambda (x y)
2598 (> (vector-ref (cdr x) 2)
2599 (vector-ref (cdr y) 2))))))
2600 (let loop ((i min-rom-encoding)
2601 (lst csts))
2602 (if (null? lst)
2603 (if (> i min-ram-encoding)
2604 (compiler-error "too many constants")
2605 csts)
2606 (begin
2607 (vector-set! (cdr (car lst)) 0 i)
2608 (loop (+ i 1)
2609 (cdr lst)))))))
2611 (define assemble
2612 (lambda (code hex-filename)
2613 (let loop1 ((lst code)
2614 (constants (predef-constants))
2615 (globals (predef-globals))
2616 (labels (list)))
2617 (if (pair? lst)
2619 (let ((instr (car lst)))
2620 (cond ((number? instr)
2621 (loop1 (cdr lst)
2622 constants
2623 globals
2624 (cons (cons instr (asm-make-label 'label))
2625 labels)))
2626 ((eq? (car instr) 'push-constant)
2627 (add-constant (cadr instr)
2628 constants
2629 #t
2630 (lambda (new-constants)
2631 (loop1 (cdr lst)
2632 new-constants
2633 globals
2634 labels))))
2635 ((memq (car instr) '(push-global set-global))
2636 (add-global (cadr instr)
2637 globals
2638 (lambda (new-globals)
2639 (loop1 (cdr lst)
2640 constants
2641 new-globals
2642 labels))))
2643 (else
2644 (loop1 (cdr lst)
2645 constants
2646 globals
2647 labels))))
2649 (let ((constants (sort-constants constants)))
2651 (define (label-instr label opcode)
2652 (asm-at-assembly
2653 (lambda (self)
2654 3)
2655 (lambda (self)
2656 (let ((pos (- (asm-label-pos label) code-start)))
2657 (asm-8 opcode)
2658 (asm-8 (quotient pos 256))
2659 (asm-8 (modulo pos 256))))))
2661 (define (push-constant n)
2662 (if (<= n 31)
2663 (asm-8 (+ #x00 n))
2664 (begin
2665 (asm-8 (+ #x90 (quotient n 256)))
2666 (asm-8 (modulo n 256)))))
2668 (define (push-stack n)
2669 (if (> n 31)
2670 (compiler-error "stack is too deep")
2671 (asm-8 (+ #x20 n))))
2673 (define (push-global n)
2674 (asm-8 (+ #x40 n)) ;; TODO maybe do the same as for csts, have a push-long-global to have more ?
2675 ;; (if (> n 15)
2676 ;; (compiler-error "too many global variables")
2677 ;; (asm-8 (+ #x40 n)))
2678 ) ;; TODO actually inline most, or put as csts
2680 (define (set-global n)
2681 (asm-8 (+ #x50 n))
2682 ;; (if (> n 15) ;; ADDED prevented the stack from compiling
2683 ;; (compiler-error "too many global variables")
2684 ;; (asm-8 (+ #x50 n)))
2685 )
2687 (define (call n)
2688 (if (> n 15)
2689 (compiler-error "call has too many arguments")
2690 (asm-8 (+ #x60 n))))
2692 (define (jump n)
2693 (if (> n 15)
2694 (compiler-error "call has too many arguments")
2695 (asm-8 (+ #x70 n))))
2697 (define (call-toplevel label)
2698 (label-instr label #x80))
2700 (define (jump-toplevel label)
2701 (label-instr label #x81))
2703 (define (goto label)
2704 (label-instr label #x82))
2706 (define (goto-if-false label)
2707 (label-instr label #x83))
2709 (define (closure label)
2710 (label-instr label #x84))
2712 (define (prim n)
2713 (asm-8 (+ #xd0 n)))
2715 (define (prim.number?) (prim 0))
2716 (define (prim.+) (prim 1))
2717 (define (prim.-) (prim 2))
2718 (define (prim.*) (prim 3))
2719 (define (prim.quotient) (prim 4))
2720 (define (prim.remainder) (prim 5))
2721 (define (prim.neg) (prim 6))
2722 (define (prim.=) (prim 7))
2723 (define (prim.<) (prim 8))
2724 (define (prim.ior) (prim 9))
2725 (define (prim.>) (prim 10))
2726 (define (prim.xor) (prim 11))
2727 (define (prim.pair?) (prim 12))
2728 (define (prim.cons) (prim 13))
2729 (define (prim.car) (prim 14))
2730 (define (prim.cdr) (prim 15))
2731 (define (prim.set-car!) (prim 16))
2732 (define (prim.set-cdr!) (prim 17))
2733 (define (prim.null?) (prim 18))
2734 (define (prim.eq?) (prim 19))
2735 (define (prim.not) (prim 20))
2736 (define (prim.get-cont) (prim 21))
2737 (define (prim.graft-to-cont) (prim 22))
2738 (define (prim.return-to-cont) (prim 23))
2739 (define (prim.halt) (prim 24))
2740 (define (prim.symbol?) (prim 25))
2741 (define (prim.string?) (prim 26))
2742 (define (prim.string->list) (prim 27))
2743 (define (prim.list->string) (prim 28))
2745 (define (prim.make-u8vector) (prim 29))
2746 (define (prim.u8vector-ref) (prim 30))
2747 (define (prim.u8vector-set!) (prim 31))
2749 (define (prim.print) (prim 32))
2750 (define (prim.clock) (prim 33))
2751 (define (prim.motor) (prim 34))
2752 (define (prim.led) (prim 35))
2753 (define (prim.led2-color) (prim 36))
2754 (define (prim.getchar-wait) (prim 37))
2755 (define (prim.putchar) (prim 38))
2756 (define (prim.beep) (prim 39))
2757 (define (prim.adc) (prim 40))
2758 (define (prim.u8vector?) (prim 41)) ;; TODO was dac
2759 (define (prim.sernum) (prim 42)) ;; TODO necessary ?
2760 (define (prim.u8vector-length) (prim 43))
2762 (define (prim.shift) (prim 45))
2763 (define (prim.pop) (prim 46))
2764 (define (prim.return) (prim 47))
2766 (define big-endian? #f)
2768 (asm-begin! code-start #f)
2770 (asm-8 #xfb)
2771 (asm-8 #xd7)
2772 (asm-8 (length constants))
2773 (asm-8 0)
2775 (pp (list constants: constants globals: globals)) ;; TODO debug
2777 (for-each
2778 (lambda (x)
2779 (let* ((descr (cdr x))
2780 (label (vector-ref descr 1))
2781 (obj (car x)))
2782 (asm-label label)
2783 ;; see the vm source for a description of encodings
2784 (cond ((and (integer? obj) (exact? obj))
2785 (asm-8 0)
2786 (asm-8 (bitwise-and (arithmetic-shift obj -16) 255))
2787 (asm-8 (bitwise-and (arithmetic-shift obj -8) 255))
2788 (asm-8 (bitwise-and obj 255)))
2789 ((pair? obj)
2790 (let ((obj-car (encode-constant (car obj) constants))
2791 (obj-cdr (encode-constant (cdr obj) constants)))
2792 (asm-8 (+ #x80 (arithmetic-shift obj-car -8)))
2793 (asm-8 (bitwise-and obj-car #xff))
2794 (asm-8 (+ 0 (arithmetic-shift obj-cdr -8)))
2795 (asm-8 (bitwise-and obj-cdr #xff))))
2796 ((symbol? obj)
2797 (asm-8 #x80)
2798 (asm-8 0)
2799 (asm-8 #x20)
2800 (asm-8 0))
2801 ((string? obj)
2802 (let ((obj-enc (encode-constant (vector-ref descr 3)
2803 constants)))
2804 (asm-8 (+ #x80 (arithmetic-shift obj-enc -8)))
2805 (asm-8 (bitwise-and obj-enc #xff))
2806 (asm-8 #x40)
2807 (asm-8 0)))
2808 ((vector? obj) ;; BREGG change this, we have no ordinary vectors
2809 ;; TODO this is the OLD representation, NOT GOOD (but not used) BREGG
2810 (let ((obj-enc (encode-constant (vector-ref descr 3)
2811 constants)))
2812 (asm-8 (+ #x80 (arithmetic-shift obj-enc -8)))
2813 (asm-8 (bitwise-and obj-enc #xff))
2814 (asm-8 #x60)
2815 (asm-8 0)))
2816 ((u8vector? obj) ;; NEW, lists for now (internal representation same as ordinary vectors, who don't actually exist)
2817 (let ((obj-enc (encode-constant (vector-ref descr 3)
2818 constants))
2819 (l (length (vector-ref descr 3))))
2820 (asm-8 (+ #x80 (arithmetic-shift l -8)))
2821 (asm-8 (bitwise-and l #xff))
2822 (asm-8 (+ #x60 (arithmetic-shift obj-enc -8)))
2823 (asm-8 (bitwise-and obj-enc #xff))))
2824 (else
2825 (compiler-error "unknown object type" obj)))))
2826 constants)
2828 (let loop2 ((lst code))
2829 (if (pair? lst)
2830 (let ((instr (car lst)))
2832 (cond ((number? instr)
2833 (let ((label (cdr (assq instr labels))))
2834 (asm-label label)))
2836 ((eq? (car instr) 'entry)
2837 (let ((np (cadr instr))
2838 (rest? (caddr instr)))
2839 (asm-8 (if rest? (- np) np))))
2841 ((eq? (car instr) 'push-constant) ;; TODO FOOBAR 12 bits for constants now (actually, I don't think it matters here)
2842 (let ((n (encode-constant (cadr instr) constants)))
2843 (push-constant n)))
2845 ((eq? (car instr) 'push-stack)
2846 (push-stack (cadr instr)))
2848 ((eq? (car instr) 'push-global)
2849 (push-global (cdr (assq (cadr instr) globals))))
2851 ((eq? (car instr) 'set-global)
2852 (set-global (cdr (assq (cadr instr) globals))))
2854 ((eq? (car instr) 'call)
2855 (call (cadr instr)))
2857 ((eq? (car instr) 'jump)
2858 (jump (cadr instr)))
2860 ((eq? (car instr) 'call-toplevel)
2861 (let ((label (cdr (assq (cadr instr) labels))))
2862 (call-toplevel label)))
2864 ((eq? (car instr) 'jump-toplevel)
2865 (let ((label (cdr (assq (cadr instr) labels))))
2866 (jump-toplevel label)))
2868 ((eq? (car instr) 'goto)
2869 (let ((label (cdr (assq (cadr instr) labels))))
2870 (goto label)))
2872 ((eq? (car instr) 'goto-if-false)
2873 (let ((label (cdr (assq (cadr instr) labels))))
2874 (goto-if-false label)))
2876 ((eq? (car instr) 'closure)
2877 (let ((label (cdr (assq (cadr instr) labels))))
2878 (closure label)))
2880 ((eq? (car instr) 'prim)
2881 (case (cadr instr)
2882 ((#%number?) (prim.number?))
2883 ((#%+) (prim.+))
2884 ((#%-) (prim.-))
2885 ((#%*) (prim.*))
2886 ((#%quotient) (prim.quotient))
2887 ((#%remainder) (prim.remainder))
2888 ((#%neg) (prim.neg))
2889 ((#%=) (prim.=))
2890 ((#%<) (prim.<))
2891 ((#%ior) (prim.ior))
2892 ((#%>) (prim.>))
2893 ((#%xor) (prim.xor))
2894 ((#%pair?) (prim.pair?))
2895 ((#%cons) (prim.cons))
2896 ((#%car) (prim.car))
2897 ((#%cdr) (prim.cdr))
2898 ((#%set-car!) (prim.set-car!))
2899 ((#%set-cdr!) (prim.set-cdr!))
2900 ((#%null?) (prim.null?))
2901 ((#%eq?) (prim.eq?))
2902 ((#%not) (prim.not))
2903 ((#%get-cont) (prim.get-cont))
2904 ((#%graft-to-cont) (prim.graft-to-cont))
2905 ((#%return-to-cont) (prim.return-to-cont))
2906 ((#%halt) (prim.halt))
2907 ((#%symbol?) (prim.symbol?))
2908 ((#%string?) (prim.string?))
2909 ((#%string->list) (prim.string->list))
2910 ((#%list->string) (prim.list->string))
2911 ((#%make-u8vector) (prim.make-u8vector))
2912 ((#%u8vector-ref) (prim.u8vector-ref))
2913 ((#%u8vector-set!) (prim.u8vector-set!))
2915 ((#%print) (prim.print))
2916 ((#%clock) (prim.clock))
2917 ((#%motor) (prim.motor))
2918 ((#%led) (prim.led))
2919 ((#%led2-color) (prim.led2-color))
2920 ((#%getchar-wait ) (prim.getchar-wait))
2921 ((#%putchar) (prim.putchar))
2922 ((#%beep) (prim.beep))
2923 ((#%adc) (prim.adc))
2924 ((#%u8vector?) (prim.u8vector?)) ;; TODO was dac
2925 ((#%sernum) (prim.sernum))
2926 ((#%u8vector-length) (prim.u8vector-length))
2927 (else
2928 (compiler-error "unknown primitive" (cadr instr)))))
2930 ((eq? (car instr) 'return)
2931 (prim.return))
2933 ((eq? (car instr) 'pop)
2934 (prim.pop))
2936 ((eq? (car instr) 'shift)
2937 (prim.shift))
2939 (else
2940 (compiler-error "unknown instruction" instr)))
2942 (loop2 (cdr lst)))))
2944 (asm-assemble)
2946 (asm-write-hex-file hex-filename)
2948 (asm-end!))))))
2950 (define execute
2951 (lambda (hex-filename)
2952 '
2953 (if #f
2954 (begin
2955 (shell-command "gcc -o picobit-vm picobit-vm.c")
2956 (shell-command (string-append "./picobit-vm " hex-filename)))
2957 (shell-command (string-append "./robot . 1 " hex-filename)))))
2959 (define (sort-list l <?)
2961 (define (mergesort l)
2963 (define (merge l1 l2)
2964 (cond ((null? l1) l2)
2965 ((null? l2) l1)
2966 (else
2967 (let ((e1 (car l1)) (e2 (car l2)))
2968 (if (<? e1 e2)
2969 (cons e1 (merge (cdr l1) l2))
2970 (cons e2 (merge l1 (cdr l2))))))))
2972 (define (split l)
2973 (if (or (null? l) (null? (cdr l)))
2974 l
2975 (cons (car l) (split (cddr l)))))
2977 (if (or (null? l) (null? (cdr l)))
2978 l
2979 (let* ((l1 (mergesort (split l)))
2980 (l2 (mergesort (split (cdr l)))))
2981 (merge l1 l2))))
2983 (mergesort l))
2985 ;------------------------------------------------------------------------------
2987 (define compile
2988 (lambda (filename)
2989 (let* ((node (parse-file filename))
2990 (hex-filename
2991 (string-append
2992 (path-strip-extension filename)
2993 ".hex")))
2995 ; (pp (node->expr node))
2997 (let ((ctx (comp-none node (make-init-context))))
2998 (let ((prog (linearize (optimize-code (context-code ctx)))))
2999 ; (pp (list code: prog env: (context-env ctx)))
3000 (assemble prog hex-filename)
3001 (execute hex-filename))))))
3004 (define main
3005 (lambda (filename)
3006 (compile filename)))
3008 ;------------------------------------------------------------------------------
3010 '
3011 (define (asm-write-hex-file filename)
3012 (with-output-to-file filename
3013 (lambda ()
3015 (define (print-hex n)
3016 (display (string-ref "0123456789ABCDEF" n)))
3018 (define (print-byte n)
3019 (display ", 0x")
3020 (print-hex (quotient n 16))
3021 (print-hex (modulo n 16)))
3023 (define (print-line type addr bytes)
3024 (let ((n (length bytes))
3025 (addr-hi (quotient addr 256))
3026 (addr-lo (modulo addr 256)))
3027 ; (display ":")
3028 ; (print-byte n)
3029 ; (print-byte addr-hi)
3030 ; (print-byte addr-lo)
3031 ; (print-byte type)
3032 (for-each print-byte bytes)
3033 (let ((sum
3034 (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
3035 ; (print-byte sum)
3036 (newline))))
3038 (let loop ((lst (cdr asm-code-stream))
3039 (pos asm-start-pos)
3040 (rev-bytes '()))
3041 (if (not (null? lst))
3042 (let ((x (car lst)))
3043 (if (vector? x)
3044 (let ((kind (vector-ref x 0)))
3045 (if (not (eq? kind 'LISTING))
3046 (compiler-internal-error
3047 "asm-write-hex-file, code stream not assembled"))
3048 (loop (cdr lst)
3049 pos
3050 rev-bytes))
3051 (let ((new-pos
3052 (+ pos 1))
3053 (new-rev-bytes
3054 (cons x
3055 (if (= (modulo pos 8) 0)
3056 (begin
3057 (print-line 0
3058 (- pos (length rev-bytes))
3059 (reverse rev-bytes))
3060 '())
3061 rev-bytes))))
3062 (loop (cdr lst)
3063 new-pos
3064 new-rev-bytes))))
3065 (begin
3066 (if (not (null? rev-bytes))
3067 (print-line 0
3068 (- pos (length rev-bytes))
3069 (reverse rev-bytes)))
3070 (print-line 1 0 '())))))))