| blob | 5a17f9123df45961091d128c17124a93e01c849c |
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 '#%<= #t '() '() '() #f (make-primitive 2 #f #f))
215 (make-var '#%> #t '() '() '() #f (make-primitive 2 #f #f))
216 (make-var '#%>= #t '() '() '() #f (make-primitive 2 #f #f))
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))
234 (make-var '#%cast-int #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED
236 (make-var '#%print #t '() '() '() #f (make-primitive 1 #f #t))
237 (make-var '#%clock #t '() '() '() #f (make-primitive 0 #f #f))
238 (make-var '#%motor #t '() '() '() #f (make-primitive 3 #f #t))
239 (make-var '#%led #t '() '() '() #f (make-primitive 1 #f #t))
240 (make-var '#%getchar-wait #t '() '() '() #f (make-primitive 1 #f #f))
241 (make-var '#%putchar #t '() '() '() #f (make-primitive 1 #f #t))
242 (make-var '#%light #t '() '() '() #f (make-primitive 0 #f #f))
244 (make-var '#%readyq #t '() '() '() #f #f)
246 )))
248 (define env-lookup
249 (lambda (env id)
250 (let loop ((lst env) (id id))
251 (let ((b (car lst)))
252 (cond ((and (renaming? b)
253 (assq id (renaming-renamings b)))
254 =>
255 (lambda (x)
256 (loop (cdr lst) (cadr x))))
257 ((and (var? b)
258 (eq? (var-id b) id))
259 b)
260 ((null? (cdr lst))
261 (let ((x (make-var id #t '() '() '() #f #f)))
262 (set-cdr! lst (cons x '()))
263 x))
264 (else
265 (loop (cdr lst) id)))))))
267 (define env-extend
268 (lambda (env ids def)
269 (append (map (lambda (id)
270 (make-var id #f '() '() (list def) #f #f))
271 ids)
272 env)))
274 (define env-extend-renamings
275 (lambda (env renamings)
276 (cons (make-renaming renamings) env)))
278 ;-----------------------------------------------------------------------------
280 ; Parsing.
282 (define parse-program
283 (lambda (expr env)
284 (let ((x (parse-top expr env)))
285 (cond ((null? x)
286 (parse 'value #f env))
287 ((null? (cdr x))
288 (car x))
289 (else
290 (let ((r (make-seq #f x)))
291 (for-each (lambda (y) (node-parent-set! y r)) x)
292 r))))))
294 (define parse-top
295 (lambda (expr env)
296 (cond ((and (pair? expr)
297 (eq? (car expr) 'begin))
298 (parse-top-list (cdr expr) env))
299 ((and (pair? expr)
300 (eq? (car expr) 'hide))
301 (parse-top-hide (cadr expr) (cddr expr) env))
302 ((and (pair? expr)
303 (eq? (car expr) 'rename))
304 (parse-top-rename (cadr expr) (cddr expr) env))
305 ((and (pair? expr)
306 (eq? (car expr) 'define))
307 (let ((var
308 (if (pair? (cadr expr))
309 (car (cadr expr))
310 (cadr expr)))
311 (val
312 (if (pair? (cadr expr))
313 (cons 'lambda (cons (cdr (cadr expr)) (cddr expr)))
314 (caddr expr))))
315 (let* ((var2 (env-lookup env var))
316 (val2 (parse 'value val env))
317 (r (make-def #f (list val2) var2)))
318 (node-parent-set! val2 r)
319 (var-defs-set! var2 (cons r (var-defs var2)))
320 (list r))))
321 (else
322 (list (parse 'value expr env))))))
324 (define parse-top-list
325 (lambda (lst env)
326 (if (pair? lst)
327 (append (parse-top (car lst) env)
328 (parse-top-list (cdr lst) env))
329 '())))
331 (define parse-top-hide
332 (lambda (renamings body env)
333 (append
334 (parse-top-list body
335 (env-extend-renamings env renamings))
336 #|
337 (parse-top-list
338 (map (lambda (x) (list 'define (car x) (cadr x))) renamings)
339 env)
340 |#
341 )))
343 (define parse-top-rename
344 (lambda (renamings body env)
345 (parse-top-list body
346 (env-extend-renamings env renamings))))
348 (define parse
349 (lambda (use expr env)
350 (cond ((self-eval? expr)
351 (make-cst #f '() expr))
352 ((symbol? expr)
353 (let* ((var (env-lookup env expr))
354 (r (make-ref #f '() var)))
355 (var-refs-set! var (cons r (var-refs var)))
356 r))
357 ((and (pair? expr) ;; ADDED
358 (eq? (car expr) 'u8vector))
359 (parse use ; call string
360 (list->string (map integer->char (cdr expr)))
361 env))
362 ((and (pair? expr)
363 (eq? (car expr) 'set!))
364 (let ((var (env-lookup env (cadr expr))))
365 (if (var-global? var)
366 (let* ((val (parse 'value (caddr expr) env))
367 (r (make-set #f (list val) var)))
368 (node-parent-set! val r)
369 (var-sets-set! var (cons r (var-sets var)))
370 r)
371 (compiler-error "set! is only permitted on global variables"))))
372 ((and (pair? expr)
373 (eq? (car expr) 'quote))
374 (make-cst #f '() (cadr expr)))
375 ((and (pair? expr)
376 (eq? (car expr) 'if))
377 (let* ((a (parse 'test (cadr expr) env))
378 (b (parse use (caddr expr) env))
379 (c (if (null? (cdddr expr))
380 (make-cst #f '() #f)
381 (parse use (cadddr expr) env)))
382 (r (make-if #f (list a b c))))
383 (node-parent-set! a r)
384 (node-parent-set! b r)
385 (node-parent-set! c r)
386 r))
387 ((and (pair? expr)
388 (eq? (car expr) 'lambda))
389 (let* ((pattern (cadr expr))
390 (ids (extract-ids pattern))
391 (r (make-prc #f '() #f (has-rest-param? pattern) #f))
392 (new-env (env-extend env ids r))
393 (body (parse-body (cddr expr) new-env)))
394 (prc-params-set! r (map (lambda (id) (env-lookup new-env id)) ids))
395 (node-children-set! r (list body))
396 (node-parent-set! body r)
397 r))
398 ((and (pair? expr)
399 (eq? (car expr) 'begin))
400 (let* ((exprs (map (lambda (x) (parse 'value x env)) (cdr expr)))
401 (r (make-seq #f exprs)))
402 (for-each (lambda (x) (node-parent-set! x r)) exprs)
403 r))
404 ((and (pair? expr)
405 (eq? (car expr) 'let))
406 (if (symbol? (cadr expr))
407 (compiler-error "named let is not implemented")
408 (parse use
409 (cons (cons 'lambda
410 (cons (map car (cadr expr))
411 (cddr expr)))
412 (map cadr (cadr expr)))
413 env)))
414 ((and (pair? expr)
415 (eq? (car expr) 'let*))
416 (if (null? (cadr expr))
417 (parse use
418 (cons 'let (cdr expr))
419 env)
420 (parse use
421 (list 'let
422 (list (list (caar (cadr expr))
423 (cadar (cadr expr))))
424 (cons 'let*
425 (cons (cdr (cadr expr))
426 (cddr expr))))
427 env)))
428 ((and (pair? expr)
429 (eq? (car expr) 'and))
430 (cond ((null? (cdr expr))
431 (parse use
432 #t
433 env))
434 ((null? (cddr expr))
435 (parse use
436 (cadr expr)
437 env))
438 (else
439 (parse use
440 (list 'if
441 (cadr expr)
442 (cons 'and (cddr expr))
443 #f)
444 env))))
445 ((and (pair? expr)
446 (eq? (car expr) 'or))
447 (cond ((null? (cdr expr))
448 (parse use
449 #f
450 env))
451 ((null? (cddr expr))
452 (parse use
453 (cadr expr)
454 env))
455 ((eq? use 'test)
456 (parse use
457 (list 'if
458 (cadr expr)
459 #t
460 (cons 'or (cddr expr)))
461 env))
462 (else
463 (parse use
464 (let ((v (gensym)))
465 (list 'let
466 (list (list v (cadr expr)))
467 (list 'if
468 v
469 v
470 (cons 'or (cddr expr)))))
471 env))))
472 ((and (pair? expr)
473 (memq (car expr)
474 '(quote quasiquote unquote unquote-splicing lambda if
475 set! cond and or case let let* letrec begin do define
476 delay)))
477 (compiler-error "the compiler does not implement the special form" (car expr)))
478 ((pair? expr)
479 (let* ((exprs (map (lambda (x) (parse 'value x env)) expr))
480 (r (make-call #f exprs)))
481 (for-each (lambda (x) (node-parent-set! x r)) exprs)
482 r))
483 (else
484 (compiler-error "unknown expression" expr)))))
486 (define parse-body
487 (lambda (exprs env)
488 (parse 'value (cons 'begin exprs) env)))
490 (define self-eval?
491 (lambda (expr)
492 (or (number? expr)
493 (char? expr)
494 (boolean? expr)
495 (string? expr))))
497 (define extract-ids
498 (lambda (pattern)
499 (if (pair? pattern)
500 (cons (car pattern) (extract-ids (cdr pattern)))
501 (if (symbol? pattern)
502 (cons pattern '())
503 '()))))
505 (define has-rest-param?
506 (lambda (pattern)
507 (if (pair? pattern)
508 (has-rest-param? (cdr pattern))
509 (symbol? pattern))))
511 ;-----------------------------------------------------------------------------
513 ; Compilation context representation.
515 (define-type context
516 code
517 env
518 env2
519 )
521 (define context-change-code
522 (lambda (ctx code)
523 (make-context code
524 (context-env ctx)
525 (context-env2 ctx))))
527 (define context-change-env
528 (lambda (ctx env)
529 (make-context (context-code ctx)
530 env
531 (context-env2 ctx))))
533 (define context-change-env2
534 (lambda (ctx env2)
535 (make-context (context-code ctx)
536 (context-env ctx)
537 env2)))
539 (define make-init-context
540 (lambda ()
541 (make-context (make-init-code)
542 (make-init-env)
543 #f)))
545 (define context-make-label
546 (lambda (ctx)
547 (context-change-code ctx (code-make-label (context-code ctx)))))
549 (define context-last-label
550 (lambda (ctx)
551 (code-last-label (context-code ctx))))
553 (define context-add-bb
554 (lambda (ctx label)
555 (context-change-code ctx (code-add-bb (context-code ctx) label))))
557 (define context-add-instr
558 (lambda (ctx instr)
559 (context-change-code ctx (code-add-instr (context-code ctx) instr))))
561 ; Representation of code.
563 (define-type code
564 last-label
565 rev-bbs
566 )
568 (define-type bb
569 label
570 rev-instrs
571 )
573 (define make-init-code
574 (lambda ()
575 (make-code 0
576 (list (make-bb 0 (list))))))
578 (define code-make-label
579 (lambda (code)
580 (let ((label (+ (code-last-label code) 1)))
581 (make-code label
582 (code-rev-bbs code)))))
584 (define code-add-bb
585 (lambda (code label)
586 (make-code
587 (code-last-label code)
588 (cons (make-bb label '())
589 (code-rev-bbs code)))))
591 (define code-add-instr
592 (lambda (code instr)
593 (let* ((rev-bbs (code-rev-bbs code))
594 (bb (car rev-bbs))
595 (rev-instrs (bb-rev-instrs bb)))
596 (make-code
597 (code-last-label code)
598 (cons (make-bb (bb-label bb)
599 (cons instr rev-instrs))
600 (cdr rev-bbs))))))
602 ; Representation of compile-time stack.
604 (define-type stack
605 size ; number of slots
606 slots ; for each slot, the variable (or #f) contained in the slot
607 )
609 (define make-init-stack
610 (lambda ()
611 (make-stack 0 '())))
613 (define stack-extend
614 (lambda (x nb-slots stk)
615 (let ((size (stack-size stk)))
616 (make-stack
617 (+ size nb-slots)
618 (append (repeat nb-slots x) (stack-slots stk))))))
620 (define stack-discard
621 (lambda (nb-slots stk)
622 (let ((size (stack-size stk)))
623 (make-stack
624 (- size nb-slots)
625 (list-tail (stack-slots stk) nb-slots)))))
627 ; Representation of compile-time environment.
629 (define-type env
630 local
631 closed
632 )
634 (define make-init-env
635 (lambda ()
636 (make-env (make-init-stack)
637 '())))
639 (define env-change-local
640 (lambda (env local)
641 (make-env local
642 (env-closed env))))
644 (define env-change-closed
645 (lambda (env closed)
646 (make-env (env-local env)
647 closed)))
649 (define find-local-var
650 (lambda (var env)
651 (let ((i (pos-in-list var (stack-slots (env-local env)))))
652 (or i
653 (- (+ (pos-in-list var (env-closed env)) 1))))))
655 (define prc->env
656 (lambda (prc)
657 (make-env
658 (let ((params (prc-params prc)))
659 (make-stack (length params)
660 (append (map var-id params) '())))
661 (let ((vars (varset->list (non-global-fv prc))))
662 ; (pp (map var-id vars))
663 (map var-id vars)))));;;;;;;;;;;;;
665 ;-----------------------------------------------------------------------------
667 (define gen-instruction
668 (lambda (instr nb-pop nb-push ctx)
669 (let* ((env
670 (context-env ctx))
671 (stk
672 (stack-extend #f
673 nb-push
674 (stack-discard nb-pop
675 (env-local env)))))
676 (context-add-instr (context-change-env ctx (env-change-local env stk))
677 instr))))
679 (define gen-entry
680 (lambda (nparams rest? ctx)
681 (gen-instruction (list 'entry nparams rest?) 0 0 ctx)))
683 (define gen-push-constant
684 (lambda (val ctx)
685 (gen-instruction (list 'push-constant val) 0 1 ctx)))
687 (define gen-push-unspecified
688 (lambda (ctx)
689 (gen-push-constant #f ctx)))
691 (define gen-push-local-var
692 (lambda (var ctx)
693 ; (pp (list var: var local: (stack-slots (env-local (context-env ctx))) (env-closed (context-env ctx))))
694 (let ((i (find-local-var var (context-env ctx))))
695 (if (>= i 0)
696 (gen-push-stack i ctx)
697 (gen-push-stack (+ (- -1 i) (length (stack-slots (env-local (context-env ctx))))) ctx)))))
699 (define gen-push-stack
700 (lambda (pos ctx)
701 (gen-instruction (list 'push-stack pos) 0 1 ctx)))
703 (define gen-push-global
704 (lambda (var ctx)
705 (gen-instruction (list 'push-global var) 0 1 ctx)))
707 (define gen-set-global
708 (lambda (var ctx)
709 (gen-instruction (list 'set-global var) 1 0 ctx)))
711 (define gen-call
712 (lambda (nargs ctx)
713 (gen-instruction (list 'call nargs) (+ nargs 1) 1 ctx)))
715 (define gen-jump
716 (lambda (nargs ctx)
717 (gen-instruction (list 'jump nargs) (+ nargs 1) 1 ctx)))
719 (define gen-call-toplevel
720 (lambda (nargs id ctx)
721 (gen-instruction (list 'call-toplevel id) nargs 1 ctx)))
723 (define gen-jump-toplevel
724 (lambda (nargs id ctx)
725 (gen-instruction (list 'jump-toplevel id) nargs 1 ctx)))
727 (define gen-goto
728 (lambda (label ctx)
729 (gen-instruction (list 'goto label) 0 0 ctx)))
731 (define gen-goto-if-false
732 (lambda (label-false label-true ctx)
733 (gen-instruction (list 'goto-if-false label-false label-true) 1 0 ctx)))
735 (define gen-closure
736 (lambda (label-entry ctx)
737 (gen-instruction (list 'closure label-entry) 2 1 ctx)))
739 (define gen-prim
740 (lambda (id nargs unspec-result? ctx)
741 (gen-instruction
742 (list 'prim id)
743 nargs
744 (if unspec-result? 0 1)
745 ctx)))
747 (define gen-shift
748 (lambda (n ctx)
749 (if (> n 0)
750 (gen-instruction (list 'shift) 1 0 (gen-shift (- n 1) ctx))
751 ctx)))
753 (define gen-pop
754 (lambda (ctx)
755 (gen-instruction (list 'pop) 1 0 ctx)))
757 (define gen-return
758 (lambda (ctx)
759 (let ((ss (stack-size (env-local (context-env ctx)))))
760 (gen-instruction (list 'return) ss 0 ctx))))
762 ;-----------------------------------------------------------------------------
764 (define child1
765 (lambda (node)
766 (car (node-children node))))
768 (define child2
769 (lambda (node)
770 (cadr (node-children node))))
772 (define child3
773 (lambda (node)
774 (caddr (node-children node))))
776 (define comp-none
777 (lambda (node ctx)
779 (cond ((or (cst? node)
780 (ref? node)
781 (prc? node))
782 ctx)
784 ((def? node)
785 (let ((var (def-var node)))
786 (if (toplevel-prc-with-non-rest-correct-calls? var)
787 (comp-prc (child1 node) #f ctx)
788 (if (var-needed? var)
789 (let ((ctx2 (comp-push (child1 node) ctx)))
790 (gen-set-global (var-id var) ctx2))
791 (comp-none (child1 node) ctx)))))
793 ((set? node)
794 (let ((var (set-var node)))
795 (if (var-needed? var)
796 (let ((ctx2 (comp-push (child1 node) ctx)))
797 (gen-set-global (var-id var) ctx2))
798 (comp-none (child1 node) ctx))))
800 ((if? node)
801 (let* ((ctx2
802 (context-make-label ctx))
803 (label-then
804 (context-last-label ctx2))
805 (ctx3
806 (context-make-label ctx2))
807 (label-else
808 (context-last-label ctx3))
809 (ctx4
810 (context-make-label ctx3))
811 (label-then-join
812 (context-last-label ctx4))
813 (ctx5
814 (context-make-label ctx4))
815 (label-else-join
816 (context-last-label ctx5))
817 (ctx6
818 (context-make-label ctx5))
819 (label-join
820 (context-last-label ctx6))
821 (ctx7
822 (comp-test (child1 node) label-then label-else ctx6))
823 (ctx8
824 (gen-goto
825 label-else-join
826 (comp-none (child3 node)
827 (context-change-env2
828 (context-add-bb ctx7 label-else)
829 #f))))
830 (ctx9
831 (gen-goto
832 label-then-join
833 (comp-none (child2 node)
834 (context-change-env
835 (context-add-bb ctx8 label-then)
836 (context-env2 ctx7)))))
837 (ctx10
838 (gen-goto
839 label-join
840 (context-add-bb ctx9 label-else-join)))
841 (ctx11
842 (gen-goto
843 label-join
844 (context-add-bb ctx10 label-then-join)))
845 (ctx12
846 (context-add-bb ctx11 label-join)))
847 ctx12))
849 ((call? node)
850 (comp-call node 'none ctx))
852 ((seq? node)
853 (let ((children (node-children node)))
854 (if (null? children)
855 ctx
856 (let loop ((lst children)
857 (ctx ctx))
858 (if (null? (cdr lst))
859 (comp-none (car lst) ctx)
860 (loop (cdr lst)
861 (comp-none (car lst) ctx)))))))
863 (else
864 (compiler-error "unknown expression type" node)))))
866 (define comp-tail
867 (lambda (node ctx)
869 (cond ((or (cst? node)
870 (ref? node)
871 (def? node)
872 (set? node)
873 (prc? node)
874 ; (call? node);;;;;;;;;;;;;;;;
875 )
876 (gen-return (comp-push node ctx)))
878 ((if? node)
879 (let* ((ctx2
880 (context-make-label ctx))
881 (label-then
882 (context-last-label ctx2))
883 (ctx3
884 (context-make-label ctx2))
885 (label-else
886 (context-last-label ctx3))
887 (ctx4
888 (comp-test (child1 node) label-then label-else ctx3))
889 (ctx5
890 (comp-tail (child3 node)
891 (context-change-env2
892 (context-add-bb ctx4 label-else)
893 #f)))
894 (ctx6
895 (comp-tail (child2 node)
896 (context-change-env
897 (context-add-bb ctx5 label-then)
898 (context-env2 ctx4)))))
899 ctx6))
901 ((call? node)
902 (comp-call node 'tail ctx))
904 ((seq? node)
905 (let ((children (node-children node)))
906 (if (null? children)
907 (gen-return (gen-push-unspecified ctx))
908 (let loop ((lst children)
909 (ctx ctx))
910 (if (null? (cdr lst))
911 (comp-tail (car lst) ctx)
912 (loop (cdr lst)
913 (comp-none (car lst) ctx)))))))
915 (else
916 (compiler-error "unknown expression type" node)))))
918 (define comp-push
919 (lambda (node ctx)
921 '(
922 (display "--------------\n")
923 (pp (node->expr node))
924 (pp env)
925 (pp stk)
926 )
928 (cond ((cst? node)
929 (let ((val (cst-val node)))
930 (gen-push-constant val ctx)))
932 ((ref? node)
933 (let ((var (ref-var node)))
934 (if (var-global? var)
935 (if (null? (var-defs var))
936 (compiler-error "undefined variable:" (var-id var))
937 (gen-push-global (var-id var) ctx))
938 (gen-push-local-var (var-id var) ctx))));;;;;;;;;;;;;
940 ((or (def? node)
941 (set? node))
942 (gen-push-unspecified (comp-none node ctx)))
944 ((if? node)
945 (let* ((ctx2
946 (context-make-label ctx))
947 (label-then
948 (context-last-label ctx2))
949 (ctx3
950 (context-make-label ctx2))
951 (label-else
952 (context-last-label ctx3))
953 (ctx4
954 (context-make-label ctx3))
955 (label-then-join
956 (context-last-label ctx4))
957 (ctx5
958 (context-make-label ctx4))
959 (label-else-join
960 (context-last-label ctx5))
961 (ctx6
962 (context-make-label ctx5))
963 (label-join
964 (context-last-label ctx6))
965 (ctx7
966 (comp-test (child1 node) label-then label-else ctx6))
967 (ctx8
968 (gen-goto
969 label-else-join
970 (comp-push (child3 node)
971 (context-change-env2
972 (context-add-bb ctx7 label-else)
973 #f))))
974 (ctx9
975 (gen-goto
976 label-then-join
977 (comp-push (child2 node)
978 (context-change-env
979 (context-add-bb ctx8 label-then)
980 (context-env2 ctx7)))))
981 (ctx10
982 (gen-goto
983 label-join
984 (context-add-bb ctx9 label-else-join)))
985 (ctx11
986 (gen-goto
987 label-join
988 (context-add-bb ctx10 label-then-join)))
989 (ctx12
990 (context-add-bb ctx11 label-join)))
991 ctx12))
993 ((prc? node)
994 (comp-prc node #t ctx))
996 ((call? node)
997 (comp-call node 'push ctx))
999 ((seq? node)
1000 (let ((children (node-children node)))
1001 (if (null? children)
1002 (gen-push-unspecified ctx)
1003 (let loop ((lst children)
1004 (ctx ctx))
1005 (if (null? (cdr lst))
1006 (comp-push (car lst) ctx)
1007 (loop (cdr lst)
1008 (comp-none (car lst) ctx)))))))
1010 (else
1011 (compiler-error "unknown expression type" node)))))
1013 (define (build-closure label-entry vars ctx)
1015 (define (build vars ctx)
1016 (if (null? vars)
1017 (gen-push-constant '() ctx)
1018 (gen-prim '#%cons
1019 2
1020 #f
1021 (build (cdr vars)
1022 (gen-push-local-var (car vars) ctx)))))
1024 (if (null? vars)
1025 (gen-closure label-entry
1026 (gen-push-constant '()
1027 (gen-push-constant #f ctx)))
1028 (gen-closure label-entry
1029 (build (cdr vars)
1030 (gen-push-local-var (car vars) ctx)))))
1032 (define comp-prc
1033 (lambda (node closure? ctx)
1034 (let* ((ctx2
1035 (context-make-label ctx))
1036 (label-entry
1037 (context-last-label ctx2))
1038 (ctx3
1039 (context-make-label ctx2))
1040 (label-continue
1041 (context-last-label ctx3))
1042 (body-env
1043 (prc->env node))
1044 (ctx4
1045 (if closure?
1046 (build-closure label-entry (env-closed body-env) ctx3)
1047 ctx3))
1048 (ctx5
1049 (gen-goto label-continue ctx4))
1050 (ctx6
1051 (gen-entry (length (prc-params node))
1052 (prc-rest? node)
1053 (context-add-bb (context-change-env ctx5
1054 body-env)
1055 label-entry)))
1056 (ctx7
1057 (comp-tail (child1 node) ctx6)))
1058 (prc-entry-label-set! node label-entry)
1059 (context-add-bb (context-change-env ctx7 (context-env ctx5))
1060 label-continue))))
1062 (define comp-call
1063 (lambda (node reason ctx)
1064 (let* ((op (child1 node))
1065 (args (cdr (node-children node)))
1066 (nargs (length args)))
1067 (let loop ((lst args)
1068 (ctx ctx))
1069 (if (pair? lst)
1071 (let ((arg (car lst)))
1072 (loop (cdr lst)
1073 (comp-push arg ctx)))
1075 (cond ((and (ref? op)
1076 (var-primitive (ref-var op)))
1077 (let* ((var (ref-var op))
1078 (id (var-id var))
1079 (primitive (var-primitive var))
1080 (prim-nargs (primitive-nargs primitive)))
1082 (define use-result
1083 (lambda (ctx2)
1084 (cond ((eq? reason 'tail)
1085 (gen-return
1086 (if (primitive-unspecified-result? primitive)
1087 (gen-push-unspecified ctx2)
1088 ctx2)))
1089 ((eq? reason 'push)
1090 (if (primitive-unspecified-result? primitive)
1091 (gen-push-unspecified ctx2)
1092 ctx2))
1093 (else
1094 (if (primitive-unspecified-result? primitive)
1095 ctx2
1096 (gen-pop ctx2))))))
1098 (use-result
1099 (if (primitive-inliner primitive)
1100 ((primitive-inliner primitive) ctx)
1101 (if (not (= nargs prim-nargs))
1102 (compiler-error "primitive called with wrong number of arguments" id)
1103 (gen-prim
1104 id
1105 prim-nargs
1106 (primitive-unspecified-result? primitive)
1107 ctx))))))
1110 ((and (ref? op)
1111 (toplevel-prc-with-non-rest-correct-calls? (ref-var op)))
1112 =>
1113 (lambda (prc)
1114 (cond ((eq? reason 'tail)
1115 (gen-jump-toplevel nargs prc ctx))
1116 ((eq? reason 'push)
1117 (gen-call-toplevel nargs prc ctx))
1118 (else
1119 (gen-pop (gen-call-toplevel nargs prc ctx))))))
1121 (else
1122 (let ((ctx2 (comp-push op ctx)))
1123 (cond ((eq? reason 'tail)
1124 (gen-jump nargs ctx2))
1125 ((eq? reason 'push)
1126 (gen-call nargs ctx2))
1127 (else
1128 (gen-pop (gen-call nargs ctx2))))))))))))
1130 (define comp-test
1131 (lambda (node label-true label-false ctx)
1132 (cond ((cst? node)
1133 (let ((ctx2
1134 (gen-goto
1135 (let ((val (cst-val node)))
1136 (if val
1137 label-true
1138 label-false))
1139 ctx)))
1140 (context-change-env2 ctx2 (context-env ctx2))))
1142 ((or (ref? node)
1143 (def? node)
1144 (set? node)
1145 (if? node)
1146 (call? node)
1147 (seq? node))
1148 (let* ((ctx2
1149 (comp-push node ctx))
1150 (ctx3
1151 (gen-goto-if-false label-false label-true ctx2)))
1152 (context-change-env2 ctx3 (context-env ctx3))))
1154 ((prc? node)
1155 (let ((ctx2
1156 (gen-goto label-true ctx)))
1157 (context-change-env2 ctx2 (context-env ctx2))))
1159 (else
1160 (compiler-error "unknown expression type" node)))))
1162 ;-----------------------------------------------------------------------------
1164 (define toplevel-prc?
1165 (lambda (var)
1166 (and (not (mutable-var? var))
1167 (let ((d (var-defs var)))
1168 (and (pair? d)
1169 (null? (cdr d))
1170 (let ((val (child1 (car d))))
1171 (and (prc? val)
1172 val)))))))
1174 (define toplevel-prc-with-non-rest-correct-calls?
1175 (lambda (var)
1176 (let ((prc (toplevel-prc? var)))
1177 (and prc
1178 (not (prc-rest? prc))
1179 (every (lambda (r)
1180 (let ((parent (node-parent r)))
1181 (and (call? parent)
1182 (eq? (child1 parent) r)
1183 (= (length (prc-params prc))
1184 (- (length (node-children parent)) 1)))))
1185 (var-refs var))
1186 prc))))
1188 (define mutable-var?
1189 (lambda (var)
1190 (not (null? (var-sets var)))))
1192 (define global-fv
1193 (lambda (node)
1194 (list->varset
1195 (keep var-global?
1196 (varset->list (fv node))))))
1198 (define non-global-fv
1199 (lambda (node)
1200 (list->varset
1201 (keep (lambda (x) (not (var-global? x)))
1202 (varset->list (fv node))))))
1204 (define fv
1205 (lambda (node)
1206 (cond ((cst? node)
1207 (varset-empty))
1208 ((ref? node)
1209 (let ((var (ref-var node)))
1210 (varset-singleton var)))
1211 ((def? node)
1212 (let ((var (def-var node))
1213 (val (child1 node)))
1214 (varset-union
1215 (varset-singleton var)
1216 (fv val))))
1217 ((set? node)
1218 (let ((var (set-var node))
1219 (val (child1 node)))
1220 (varset-union
1221 (varset-singleton var)
1222 (fv val))))
1223 ((if? node)
1224 (let ((a (list-ref (node-children node) 0))
1225 (b (list-ref (node-children node) 1))
1226 (c (list-ref (node-children node) 2)))
1227 (varset-union-multi (list (fv a) (fv b) (fv c)))))
1228 ((prc? node)
1229 (let ((body (list-ref (node-children node) 0)))
1230 (varset-difference
1231 (fv body)
1232 (build-params-varset (prc-params node)))))
1233 ((call? node)
1234 (varset-union-multi (map fv (node-children node))))
1235 ((seq? node)
1236 (varset-union-multi (map fv (node-children node))))
1237 (else
1238 (compiler-error "unknown expression type" node)))))
1240 (define build-params-varset
1241 (lambda (params)
1242 (list->varset params)))
1244 (define mark-needed-global-vars!
1245 (lambda (global-env node)
1247 (define readyq
1248 (env-lookup global-env '#%readyq))
1250 (define mark-var!
1251 (lambda (var)
1252 (if (and (var-global? var)
1253 (not (var-needed? var)))
1254 (begin
1255 (var-needed?-set! var #t)
1256 (for-each
1257 (lambda (def)
1258 (let ((val (child1 def)))
1259 (if (side-effect-less? val)
1260 (mark! val))))
1261 (var-defs var))
1262 (if (eq? var readyq)
1263 (begin
1264 (mark-var!
1265 (env-lookup global-env '#%start-first-process))
1266 (mark-var!
1267 (env-lookup global-env '#%exit))))))))
1269 (define side-effect-less?
1270 (lambda (node)
1271 (or (cst? node)
1272 (ref? node)
1273 (prc? node))))
1275 (define mark!
1276 (lambda (node)
1277 (cond ((cst? node))
1278 ((ref? node)
1279 (let ((var (ref-var node)))
1280 (mark-var! var)))
1281 ((def? node)
1282 (let ((var (def-var node))
1283 (val (child1 node)))
1284 (if (not (side-effect-less? val))
1285 (mark! val))))
1286 ((set? node)
1287 (let ((var (set-var node))
1288 (val (child1 node)))
1289 (mark! val)))
1290 ((if? node)
1291 (let ((a (list-ref (node-children node) 0))
1292 (b (list-ref (node-children node) 1))
1293 (c (list-ref (node-children node) 2)))
1294 (mark! a)
1295 (mark! b)
1296 (mark! c)))
1297 ((prc? node)
1298 (let ((body (list-ref (node-children node) 0)))
1299 (mark! body)))
1300 ((call? node)
1301 (for-each mark! (node-children node)))
1302 ((seq? node)
1303 (for-each mark! (node-children node)))
1304 (else
1305 (compiler-error "unknown expression type" node)))))
1307 (mark! node)
1308 ))
1310 ;-----------------------------------------------------------------------------
1312 ; Variable sets
1314 (define (varset-empty) ; return the empty set
1315 '())
1317 (define (varset-singleton x) ; create a set containing only 'x'
1318 (list x))
1320 (define (list->varset lst) ; convert list to set
1321 lst)
1323 (define (varset->list set) ; convert set to list
1324 set)
1326 (define (varset-size set) ; return cardinality of set
1327 (list-length set))
1329 (define (varset-empty? set) ; is 'x' the empty set?
1330 (null? set))
1332 (define (varset-member? x set) ; is 'x' a member of the 'set'?
1333 (and (not (null? set))
1334 (or (eq? x (car set))
1335 (varset-member? x (cdr set)))))
1337 (define (varset-adjoin set x) ; add the element 'x' to the 'set'
1338 (if (varset-member? x set) set (cons x set)))
1340 (define (varset-remove set x) ; remove the element 'x' from 'set'
1341 (cond ((null? set)
1342 '())
1343 ((eq? (car set) x)
1344 (cdr set))
1345 (else
1346 (cons (car set) (varset-remove (cdr set) x)))))
1348 (define (varset-equal? s1 s2) ; are 's1' and 's2' equal sets?
1349 (and (varset-subset? s1 s2)
1350 (varset-subset? s2 s1)))
1352 (define (varset-subset? s1 s2) ; is 's1' a subset of 's2'?
1353 (cond ((null? s1)
1354 #t)
1355 ((varset-member? (car s1) s2)
1356 (varset-subset? (cdr s1) s2))
1357 (else
1358 #f)))
1360 (define (varset-difference set1 set2) ; return difference of sets
1361 (cond ((null? set1)
1362 '())
1363 ((varset-member? (car set1) set2)
1364 (varset-difference (cdr set1) set2))
1365 (else
1366 (cons (car set1) (varset-difference (cdr set1) set2)))))
1368 (define (varset-union set1 set2) ; return union of sets
1369 (define (union s1 s2)
1370 (cond ((null? s1)
1371 s2)
1372 ((varset-member? (car s1) s2)
1373 (union (cdr s1) s2))
1374 (else
1375 (cons (car s1) (union (cdr s1) s2)))))
1376 (if (varset-smaller? set1 set2)
1377 (union set1 set2)
1378 (union set2 set1)))
1380 (define (varset-intersection set1 set2) ; return intersection of sets
1381 (define (intersection s1 s2)
1382 (cond ((null? s1)
1383 '())
1384 ((varset-member? (car s1) s2)
1385 (cons (car s1) (intersection (cdr s1) s2)))
1386 (else
1387 (intersection (cdr s1) s2))))
1388 (if (varset-smaller? set1 set2)
1389 (intersection set1 set2)
1390 (intersection set2 set1)))
1392 (define (varset-intersects? set1 set2) ; do sets 'set1' and 'set2' intersect?
1393 (not (varset-empty? (varset-intersection set1 set2))))
1395 (define (varset-smaller? set1 set2)
1396 (if (null? set1)
1397 (not (null? set2))
1398 (if (null? set2)
1399 #f
1400 (varset-smaller? (cdr set1) (cdr set2)))))
1402 (define (varset-union-multi sets)
1403 (if (null? sets)
1404 (varset-empty)
1405 (n-ary varset-union (car sets) (cdr sets))))
1407 (define (n-ary function first rest)
1408 (if (null? rest)
1409 first
1410 (n-ary function (function first (car rest)) (cdr rest))))
1412 ;------------------------------------------------------------------------------
1414 (define code->vector
1415 (lambda (code)
1416 (let ((v (make-vector (+ (code-last-label code) 1))))
1417 (for-each
1418 (lambda (bb)
1419 (vector-set! v (bb-label bb) bb))
1420 (code-rev-bbs code))
1421 v)))
1423 (define bbs->ref-counts
1424 (lambda (bbs)
1425 (let ((ref-counts (make-vector (vector-length bbs) 0)))
1427 (define visit
1428 (lambda (label)
1429 (let ((ref-count (vector-ref ref-counts label)))
1430 (vector-set! ref-counts label (+ ref-count 1))
1431 (if (= ref-count 0)
1432 (let* ((bb (vector-ref bbs label))
1433 (rev-instrs (bb-rev-instrs bb)))
1434 (for-each
1435 (lambda (instr)
1436 (let ((opcode (car instr)))
1437 (cond ((eq? opcode 'goto)
1438 (visit (cadr instr)))
1439 ((eq? opcode 'goto-if-false)
1440 (visit (cadr instr))
1441 (visit (caddr instr)))
1442 ((or (eq? opcode 'closure)
1443 (eq? opcode 'call-toplevel)
1444 (eq? opcode 'jump-toplevel))
1445 (visit (cadr instr))))))
1446 rev-instrs))))))
1448 (visit 0)
1450 ref-counts)))
1452 (define resolve-toplevel-labels!
1453 (lambda (bbs)
1454 (let loop ((i 0))
1455 (if (< i (vector-length bbs))
1456 (let* ((bb (vector-ref bbs i))
1457 (rev-instrs (bb-rev-instrs bb)))
1458 (bb-rev-instrs-set!
1459 bb
1460 (map (lambda (instr)
1461 (let ((opcode (car instr)))
1462 (cond ((eq? opcode 'call-toplevel)
1463 (list opcode
1464 (prc-entry-label (cadr instr))))
1465 ((eq? opcode 'jump-toplevel)
1466 (list opcode
1467 (prc-entry-label (cadr instr))))
1468 (else
1469 instr))))
1470 rev-instrs))
1471 (loop (+ i 1)))))))
1473 (define tighten-jump-cascades!
1474 (lambda (bbs)
1475 (let ((ref-counts (bbs->ref-counts bbs)))
1477 (define resolve
1478 (lambda (label)
1479 (let* ((bb (vector-ref bbs label))
1480 (rev-instrs (bb-rev-instrs bb)))
1481 (and (or (null? (cdr rev-instrs))
1482 (= (vector-ref ref-counts label) 1))
1483 rev-instrs))))
1485 (let loop1 ()
1486 (let loop2 ((i 0)
1487 (changed? #f))
1488 (if (< i (vector-length bbs))
1489 (if (> (vector-ref ref-counts i) 0)
1490 (let* ((bb (vector-ref bbs i))
1491 (rev-instrs (bb-rev-instrs bb))
1492 (jump (car rev-instrs))
1493 (opcode (car jump)))
1494 (cond ((eq? opcode 'goto)
1495 (let* ((label (cadr jump))
1496 (jump-replacement (resolve label)))
1497 (if jump-replacement
1498 (begin
1499 (vector-set!
1500 bbs
1501 i
1502 (make-bb (bb-label bb)
1503 (append jump-replacement
1504 (cdr rev-instrs))))
1505 (loop2 (+ i 1)
1506 #t))
1507 (loop2 (+ i 1)
1508 changed?))))
1509 ((eq? opcode 'goto-if-false)
1510 (let* ((label-then (cadr jump))
1511 (label-else (caddr jump))
1512 (jump-then-replacement (resolve label-then))
1513 (jump-else-replacement (resolve label-else)))
1514 (if (and jump-then-replacement
1515 (null? (cdr jump-then-replacement))
1516 jump-else-replacement
1517 (null? (cdr jump-else-replacement))
1518 (or (eq? (caar jump-then-replacement) 'goto)
1519 (eq? (caar jump-else-replacement) 'goto)))
1520 (begin
1521 (vector-set!
1522 bbs
1523 i
1524 (make-bb (bb-label bb)
1525 (cons (list 'goto-if-false
1526 (if (eq? (caar jump-then-replacement) 'goto)
1527 (cadar jump-then-replacement)
1528 label-then)
1529 (if (eq? (caar jump-else-replacement) 'goto)
1530 (cadar jump-else-replacement)
1531 label-else))
1532 (cdr rev-instrs))))
1533 (loop2 (+ i 1)
1534 #t))
1535 (loop2 (+ i 1)
1536 changed?))))
1537 (else
1538 (loop2 (+ i 1)
1539 changed?))))
1540 (loop2 (+ i 1)
1541 changed?))
1542 (if changed?
1543 (loop1))))))))
1545 (define remove-useless-bbs!
1546 (lambda (bbs)
1547 (let ((ref-counts (bbs->ref-counts bbs)))
1548 (let loop1 ((label 0) (new-label 0))
1549 (if (< label (vector-length bbs))
1550 (if (> (vector-ref ref-counts label) 0)
1551 (let ((bb (vector-ref bbs label)))
1552 (vector-set!
1553 bbs
1554 label
1555 (make-bb new-label (bb-rev-instrs bb)))
1556 (loop1 (+ label 1) (+ new-label 1)))
1557 (loop1 (+ label 1) new-label))
1558 (renumber-labels bbs ref-counts new-label))))))
1560 (define renumber-labels
1561 (lambda (bbs ref-counts n)
1562 (let ((new-bbs (make-vector n)))
1563 (let loop2 ((label 0))
1564 (if (< label (vector-length bbs))
1565 (if (> (vector-ref ref-counts label) 0)
1566 (let* ((bb (vector-ref bbs label))
1567 (new-label (bb-label bb))
1568 (rev-instrs (bb-rev-instrs bb)))
1570 (define fix
1571 (lambda (instr)
1573 (define new-label
1574 (lambda (label)
1575 (bb-label (vector-ref bbs label))))
1577 (let ((opcode (car instr)))
1578 (cond ((eq? opcode 'closure)
1579 (list 'closure
1580 (new-label (cadr instr))))
1581 ((eq? opcode 'call-toplevel)
1582 (list 'call-toplevel
1583 (new-label (cadr instr))))
1584 ((eq? opcode 'jump-toplevel)
1585 (list 'jump-toplevel
1586 (new-label (cadr instr))))
1587 ((eq? opcode 'goto)
1588 (list 'goto
1589 (new-label (cadr instr))))
1590 ((eq? opcode 'goto-if-false)
1591 (list 'goto-if-false
1592 (new-label (cadr instr))
1593 (new-label (caddr instr))))
1594 (else
1595 instr)))))
1597 (vector-set!
1598 new-bbs
1599 new-label
1600 (make-bb new-label (map fix rev-instrs)))
1601 (loop2 (+ label 1)))
1602 (loop2 (+ label 1)))
1603 new-bbs)))))
1605 (define reorder!
1606 (lambda (bbs)
1607 (let* ((done (make-vector (vector-length bbs) #f)))
1609 (define unscheduled?
1610 (lambda (label)
1611 (not (vector-ref done label))))
1613 (define label-refs
1614 (lambda (instrs todo)
1615 (if (pair? instrs)
1616 (let* ((instr (car instrs))
1617 (opcode (car instr)))
1618 (cond ((or (eq? opcode 'closure)
1619 (eq? opcode 'call-toplevel)
1620 (eq? opcode 'jump-toplevel))
1621 (label-refs (cdr instrs) (cons (cadr instr) todo)))
1622 (else
1623 (label-refs (cdr instrs) todo))))
1624 todo)))
1626 (define schedule-here
1627 (lambda (label new-label todo cont)
1628 (let* ((bb (vector-ref bbs label))
1629 (rev-instrs (bb-rev-instrs bb))
1630 (jump (car rev-instrs))
1631 (opcode (car jump))
1632 (new-todo (label-refs rev-instrs todo)))
1633 (vector-set! bbs label (make-bb new-label rev-instrs))
1634 (vector-set! done label #t)
1635 (cond ((eq? opcode 'goto)
1636 (let ((label (cadr jump)))
1637 (if (unscheduled? label)
1638 (schedule-here label
1639 (+ new-label 1)
1640 new-todo
1641 cont)
1642 (cont (+ new-label 1)
1643 new-todo))))
1644 ((eq? opcode 'goto-if-false)
1645 (let ((label-then (cadr jump))
1646 (label-else (caddr jump)))
1647 (cond ((unscheduled? label-else)
1648 (schedule-here label-else
1649 (+ new-label 1)
1650 (cons label-then new-todo)
1651 cont))
1652 ((unscheduled? label-then)
1653 (schedule-here label-then
1654 (+ new-label 1)
1655 new-todo
1656 cont))
1657 (else
1658 (cont (+ new-label 1)
1659 new-todo)))))
1660 (else
1661 (cont (+ new-label 1)
1662 new-todo))))))
1664 (define schedule-somewhere
1665 (lambda (label new-label todo cont)
1666 (schedule-here label new-label todo cont)))
1668 (define schedule-todo
1669 (lambda (new-label todo)
1670 (if (pair? todo)
1671 (let ((label (car todo)))
1672 (if (unscheduled? label)
1673 (schedule-somewhere label
1674 new-label
1675 (cdr todo)
1676 schedule-todo)
1677 (schedule-todo new-label
1678 (cdr todo)))))))
1681 (schedule-here 0 0 '() schedule-todo)
1683 (renumber-labels bbs
1684 (make-vector (vector-length bbs) 1)
1685 (vector-length bbs)))))
1687 (define linearize
1688 (lambda (bbs)
1689 (let loop ((label (- (vector-length bbs) 1))
1690 (lst '()))
1691 (if (>= label 0)
1692 (let* ((bb (vector-ref bbs label))
1693 (rev-instrs (bb-rev-instrs bb))
1694 (jump (car rev-instrs))
1695 (opcode (car jump)))
1696 (loop (- label 1)
1697 (append
1698 (list label)
1699 (reverse
1700 (cond ((eq? opcode 'goto)
1701 (if (= (cadr jump) (+ label 1))
1702 (cdr rev-instrs)
1703 rev-instrs))
1704 ((eq? opcode 'goto-if-false)
1705 (cond ((= (caddr jump) (+ label 1))
1706 (cons (list 'goto-if-false (cadr jump))
1707 (cdr rev-instrs)))
1708 ((= (cadr jump) (+ label 1))
1709 (cons (list 'goto-if-not-false (caddr jump))
1710 (cdr rev-instrs)))
1711 (else
1712 (cons (list 'goto (caddr jump))
1713 (cons (list 'goto-if-false (cadr jump))
1714 (cdr rev-instrs))))))
1715 (else
1716 rev-instrs)))
1717 lst)))
1718 lst))))
1720 (define optimize-code
1721 (lambda (code)
1722 (let ((bbs (code->vector code)))
1723 (resolve-toplevel-labels! bbs)
1724 (tighten-jump-cascades! bbs)
1725 (let ((bbs (remove-useless-bbs! bbs)))
1726 (reorder! bbs)))))
1728 (define parse-file
1729 (lambda (filename)
1730 (let* ((library
1731 (with-input-from-file "library.scm" read-all))
1732 (toplevel-exprs
1733 (append library
1734 (with-input-from-file filename read-all)))
1735 (global-env
1736 (make-global-env))
1737 (parsed-prog
1738 (parse-top (cons 'begin toplevel-exprs) global-env)))
1740 (for-each
1741 (lambda (node)
1742 (mark-needed-global-vars! global-env node))
1743 parsed-prog)
1745 (extract-parts
1746 parsed-prog
1747 (lambda (defs after-defs)
1749 (define make-seq-preparsed
1750 (lambda (exprs)
1751 (let ((r (make-seq #f exprs)))
1752 (for-each (lambda (x) (node-parent-set! x r)) exprs)
1753 r)))
1755 (define make-call-preparsed
1756 (lambda (exprs)
1757 (let ((r (make-call #f exprs)))
1758 (for-each (lambda (x) (node-parent-set! x r)) exprs)
1759 r)))
1761 (if (var-needed?
1762 (env-lookup global-env '#%readyq))
1763 (make-seq-preparsed
1764 (list (make-seq-preparsed defs)
1765 (make-call-preparsed
1766 (list (parse 'value '#%start-first-process global-env)
1767 (let* ((pattern
1768 '())
1769 (ids
1770 (extract-ids pattern))
1771 (r
1772 (make-prc #f '() #f (has-rest-param? pattern) #f))
1773 (new-env
1774 (env-extend global-env ids r))
1775 (body
1776 (make-seq-preparsed after-defs)))
1777 (prc-params-set!
1778 r
1779 (map (lambda (id) (env-lookup new-env id))
1780 ids))
1781 (node-children-set! r (list body))
1782 (node-parent-set! body r)
1783 r)))
1784 (parse 'value
1785 '(#%exit)
1786 global-env)))
1787 (make-seq-preparsed
1788 (append defs
1789 after-defs
1790 (list (parse 'value
1791 '(#%halt)
1792 global-env))))))))))
1794 (define extract-parts
1795 (lambda (lst cont)
1796 (if (or (null? lst)
1797 (not (def? (car lst))))
1798 (cont '() lst)
1799 (extract-parts
1800 (cdr lst)
1801 (lambda (d ad)
1802 (cont (cons (car lst) d) ad))))))
1804 ;------------------------------------------------------------------------------
1806 ;(include "asm.scm")
1808 ;;; File: "asm.scm"
1809 ;;;
1810 ;;; This module implements the generic assembler.
1812 ;(##declare (standard-bindings) (fixnum) (block))
1814 (define compiler-internal-error error)
1816 ;; (asm-begin! start-pos big-endian?) initializes the assembler and
1817 ;; starts a new empty code stream at address "start-pos". It must be
1818 ;; called every time a new code stream is to be built. The argument
1819 ;; "big-endian?" indicates the byte ordering to use for 16, 32 and 64
1820 ;; bit values. After a call to "asm-begin!" the code stream is built
1821 ;; by calling the following procedures:
1822 ;;
1823 ;; asm-8 to add an 8 bit integer to the code stream
1824 ;; asm-16 to add a 16 bit integer to the code stream
1825 ;; asm-32 to add a 32 bit integer to the code stream
1826 ;; asm-64 to add a 64 bit integer to the code stream
1827 ;; asm-float64 to add a 64 bit IEEE float to the code stream
1828 ;; asm-string to add a null terminated string to the code stream
1829 ;; asm-label to set a label to the current position in the code stream
1830 ;; asm-align to add enough zero bytes to force alignment
1831 ;; asm-origin to add enough zero bytes to move to a particular address
1832 ;; asm-at-assembly to defer code production to assembly time
1833 ;; asm-listing to add textual information to the listing
1835 (define (asm-begin! start-pos big-endian?)
1836 (set! asm-start-pos start-pos)
1837 (set! asm-big-endian? big-endian?)
1838 (set! asm-code-stream (asm-make-stream))
1839 #f)
1841 ;; (asm-end!) must be called to finalize the assembler.
1843 (define (asm-end!)
1844 (set! asm-code-stream #f)
1845 #f)
1847 ;; (asm-8 n) adds an 8 bit signed or unsigned integer to the code stream.
1849 (define (asm-8 n)
1850 (asm-code-extend (asm-bits-0-to-7 n)))
1852 ;; (asm-16 n) adds a 16 bit signed or unsigned integer to the code stream.
1854 (define (asm-16 n)
1855 (if asm-big-endian?
1856 (begin (asm-8 (asm-bits-8-and-up n)) (asm-8 n))
1857 (begin (asm-8 n) (asm-8 (asm-bits-8-and-up n)))))
1859 ;; (asm-32 n) adds a 32 bit signed or unsigned integer to the code stream.
1861 (define (asm-32 n)
1862 (if asm-big-endian?
1863 (begin (asm-16 (asm-bits-16-and-up n)) (asm-16 n))
1864 (begin (asm-16 n) (asm-16 (asm-bits-16-and-up n)))))
1866 ;; (asm-64 n) adds a 64 bit signed or unsigned integer to the code stream.
1868 (define (asm-64 n)
1869 (if asm-big-endian?
1870 (begin (asm-32 (asm-bits-32-and-up n)) (asm-32 n))
1871 (begin (asm-32 n) (asm-32 (asm-bits-32-and-up n)))))
1873 ;; (asm-float64 n) adds a 64 bit IEEE floating point number to the code stream.
1875 (define (asm-float64 n)
1876 (asm-64 (asm-float->bits n)))
1878 ;; (asm-string str) adds a null terminated string to the code stream.
1880 (define (asm-string str)
1881 (let ((len (string-length str)))
1882 (let loop ((i 0))
1883 (if (< i len)
1884 (begin
1885 (asm-8 (char->integer (string-ref str i)))
1886 (loop (+ i 1)))
1887 (asm-8 0)))))
1889 (define (asm-u8vector u8) ;; ADDED, pretty much the same as strings
1890 (let ((len (u8vector-length u8)))
1891 (let loop ((i 0))
1892 (if (< i len)
1893 (begin
1894 (asm-8 (u8vector-ref u8 i))
1895 (loop (+ i 1)))
1896 (asm-8 0)))))
1898 ;; (asm-make-label id) creates a new label object. A label can
1899 ;; be queried with "asm-label-pos" to obtain the label's position
1900 ;; relative to the start of the code stream (i.e. "start-pos").
1901 ;; The argument "id" gives a name to the label (not necessarily
1902 ;; unique) and is only needed for debugging purposes.
1904 (define (asm-make-label id)
1905 (vector 'LABEL #f id))
1907 ;; (asm-label label-obj) sets the label to the current position in the
1908 ;; code stream.
1910 (define (asm-label label-obj)
1911 (if (vector-ref label-obj 1)
1912 (compiler-internal-error
1913 "asm-label, label multiply defined" (asm-label-id label-obj))
1914 (begin
1915 (vector-set! label-obj 1 0)
1916 (asm-code-extend label-obj))))
1918 ;; (asm-label-id label-obj) returns the identifier of the label object.
1920 (define (asm-label-id label-obj)
1921 (vector-ref label-obj 2))
1923 ;; (asm-label-pos label-obj) returns the position of the label
1924 ;; relative to the start of the code stream (i.e. "start-pos").
1925 ;; This procedure can only be called at assembly time (i.e.
1926 ;; within the call to "asm-assemble") or after assembly time
1927 ;; for labels declared prior to assembly time with "asm-label".
1928 ;; A label declared at assembly time can only be queried after
1929 ;; assembly time. Moreover, at assembly time the position of a
1930 ;; label may vary from one call to the next due to the actions
1931 ;; of the assembler.
1933 (define (asm-label-pos label-obj)
1934 (let ((pos (vector-ref label-obj 1)))
1935 (if pos
1936 pos
1937 (compiler-internal-error
1938 "asm-label-pos, undefined label" (asm-label-id label-obj)))))
1940 ;; (asm-align multiple offset) adds enough zero bytes to the code
1941 ;; stream to force alignment to the next address congruent to
1942 ;; "offset" modulo "multiple".
1944 (define (asm-align multiple offset)
1945 (asm-at-assembly
1946 (lambda (self)
1947 (modulo (- multiple (- self offset)) multiple))
1948 (lambda (self)
1949 (let loop ((n (modulo (- multiple (- self offset)) multiple)))
1950 (if (> n 0)
1951 (begin
1952 (asm-8 0)
1953 (loop (- n 1))))))))
1955 ;; (asm-origin address) adds enough zero bytes to the code stream to move
1956 ;; to the address "address".
1958 (define (asm-origin address)
1959 (asm-at-assembly
1960 (lambda (self)
1961 (- address self))
1962 (lambda (self)
1963 (let ((len (- address self)))
1964 (if (< len 0)
1965 (compiler-internal-error "asm-origin, can't move back")
1966 (let loop ((n len))
1967 (if (> n 0)
1968 (begin
1969 (asm-8 0)
1970 (loop (- n 1))))))))))
1972 ;; (asm-at-assembly . procs) makes it possible to defer code
1973 ;; production to assembly time. A useful application is to generate
1974 ;; position dependent and span dependent code sequences. This
1975 ;; procedure must be passed an even number of procedures. All odd
1976 ;; indexed procedures (including the first procedure) are called "check"
1977 ;; procedures. The even indexed procedures are the "production"
1978 ;; procedures which, when called, produce a particular code sequence.
1979 ;; A check procedure decides if, given the current state of assembly
1980 ;; (in particular the current positioning of the labels), the code
1981 ;; produced by the corresponding production procedure is valid.
1982 ;; If the code is not valid, the check procedure must return #f.
1983 ;; If the code is valid, the check procedure must return the length
1984 ;; of the code sequence in bytes. The assembler will try each check
1985 ;; procedure in order until it finds one that does not return #f
1986 ;; (the last check procedure must never return #f). For convenience,
1987 ;; the current position in the code sequence is passed as the single
1988 ;; argument of check and production procedures.
1989 ;;
1990 ;; Here is a sample call of "asm-at-assembly" to produce the
1991 ;; shortest branch instruction to branch to label "x" for a
1992 ;; hypothetical processor:
1993 ;;
1994 ;; (asm-at-assembly
1995 ;;
1996 ;; (lambda (self) ; first check procedure
1997 ;; (let ((dist (- (asm-label-pos x) self)))
1998 ;; (if (and (>= dist -128) (<= dist 127)) ; short branch possible?
1999 ;; 2
2000 ;; #f)))
2001 ;;
2002 ;; (lambda (self) ; first production procedure
2003 ;; (asm-8 #x34) ; branch opcode for 8 bit displacement
2004 ;; (asm-8 (- (asm-label-pos x) self)))
2005 ;;
2006 ;; (lambda (self) 5) ; second check procedure
2007 ;;
2008 ;; (lambda (self) ; second production procedure
2009 ;; (asm-8 #x35) ; branch opcode for 32 bit displacement
2010 ;; (asm-32 (- (asm-label-pos x) self))))
2012 (define (asm-at-assembly . procs)
2013 (asm-code-extend (vector 'DEFERRED procs)))
2015 ;; (asm-listing text) adds text to the right side of the listing.
2016 ;; The atoms in "text" will be output using "display" (lists are
2017 ;; traversed recursively). The listing is generated by calling
2018 ;; "asm-display-listing".
2020 (define (asm-listing text)
2021 (asm-code-extend (vector 'LISTING text)))
2023 ;; (asm-assemble) assembles the code stream. After assembly, the
2024 ;; label objects will be set to their final position and the
2025 ;; alignment bytes and the deferred code will have been produced. It
2026 ;; is possible to extend the code stream after assembly. However, if
2027 ;; any of the procedures "asm-label", "asm-align", and
2028 ;; "asm-at-assembly" are called, the code stream will have to be
2029 ;; assembled once more.
2031 (define (asm-assemble)
2032 (let ((fixup-lst (asm-pass1)))
2034 (let loop1 ()
2035 (let loop2 ((lst fixup-lst)
2036 (changed? #f)
2037 (pos asm-start-pos))
2038 (if (null? lst)
2039 (if changed? (loop1))
2040 (let* ((fixup (car lst))
2041 (pos (+ pos (car fixup)))
2042 (curr (cdr fixup))
2043 (x (car curr)))
2044 (if (eq? (vector-ref x 0) 'LABEL)
2045 ; LABEL
2046 (if (= (vector-ref x 1) pos)
2047 (loop2 (cdr lst) changed? pos)
2048 (begin
2049 (vector-set! x 1 pos)
2050 (loop2 (cdr lst) #t pos)))
2051 ; DEFERRED
2052 (let loop3 ()
2053 (let ((n ((car (vector-ref x 1)) pos)))
2054 (if n
2055 (loop2 (cdr lst) changed? (+ pos n))
2056 (begin
2057 (vector-set! x 1 (cddr (vector-ref x 1)))
2058 (loop3))))))))))
2060 (let loop4 ((prev asm-code-stream)
2061 (curr (cdr asm-code-stream))
2062 (pos asm-start-pos))
2063 (if (null? curr)
2064 (set-car! asm-code-stream prev)
2065 (let ((x (car curr))
2066 (next (cdr curr)))
2067 (if (vector? x)
2068 (let ((kind (vector-ref x 0)))
2069 (cond ((eq? kind 'LABEL)
2070 (let ((final-pos (vector-ref x 1)))
2071 (if final-pos
2072 (if (not (= pos final-pos))
2073 (compiler-internal-error
2074 "asm-assemble, inconsistency detected"))
2075 (vector-set! x 1 pos))
2076 (set-cdr! prev next)
2077 (loop4 prev next pos)))
2078 ((eq? kind 'DEFERRED)
2079 (let ((temp asm-code-stream))
2080 (set! asm-code-stream (asm-make-stream))
2081 ((cadr (vector-ref x 1)) pos)
2082 (let ((tail (car asm-code-stream)))
2083 (set-cdr! tail next)
2084 (let ((head (cdr asm-code-stream)))
2085 (set-cdr! prev head)
2086 (set! asm-code-stream temp)
2087 (loop4 prev head pos)))))
2088 (else
2089 (loop4 curr next pos))))
2090 (loop4 curr next (+ pos 1))))))))
2092 ;; (asm-display-listing port) produces a listing of the code stream
2093 ;; on the given output port. The bytes generated are shown in
2094 ;; hexadecimal on the left side of the listing and the right side
2095 ;; of the listing contains the text inserted by "asm-listing".
2097 (define (asm-display-listing port)
2099 (define text-col 24)
2100 (define pos-width 6)
2101 (define byte-width 2)
2103 (define (output text)
2104 (cond ((null? text))
2105 ((pair? text)
2106 (output (car text))
2107 (output (cdr text)))
2108 (else
2109 (display text port))))
2111 (define (print-hex n)
2112 (display (string-ref "0123456789ABCDEF" n) port))
2114 (define (print-byte n)
2115 (print-hex (quotient n 16))
2116 (print-hex (modulo n 16)))
2118 (define (print-pos n)
2119 (if (< n 0)
2120 (display " " port)
2121 (begin
2122 (print-byte (quotient n #x10000))
2123 (print-byte (modulo (quotient n #x100) #x100))
2124 (print-byte (modulo n #x100)))))
2126 (let loop1 ((lst (cdr asm-code-stream)) (pos asm-start-pos) (col 0))
2127 (if (null? lst)
2128 (if (> col 0)
2129 (newline port))
2130 (let ((x (car lst)))
2131 (if (vector? x)
2132 (let ((kind (vector-ref x 0)))
2133 (cond ((eq? kind 'LISTING)
2134 (let loop2 ((col col))
2135 (if (< col text-col)
2136 (begin
2137 (display (integer->char 9) port)
2138 (loop2 (* 8 (+ (quotient col 8) 1))))))
2139 (output (vector-ref x 1))
2140 (newline port)
2141 (loop1 (cdr lst) pos 0))
2142 (else
2143 (compiler-internal-error
2144 "asm-display-listing, code stream not assembled"))))
2145 (if (or (= col 0) (>= col (- text-col byte-width)))
2146 (begin
2147 (if (not (= col 0)) (newline port))
2148 (print-pos pos)
2149 (display " " port)
2150 (print-byte x)
2151 (loop1 (cdr lst) (+ pos 1) (+ (+ pos-width 1) byte-width)))
2152 (begin
2153 (print-byte x)
2154 (loop1 (cdr lst) (+ pos 1) (+ col byte-width)))))))))
2156 ;; (asm-write-code filename) outputs the code stream (i.e. the sequence
2157 ;; of bytes produced) on the named file.
2159 (define (asm-write-code filename)
2160 (with-output-to-file filename
2161 (lambda ()
2162 (let loop ((lst (cdr asm-code-stream)))
2163 (if (not (null? lst))
2164 (let ((x (car lst)))
2165 (if (vector? x)
2166 (let ((kind (vector-ref x 0)))
2167 (if (not (eq? kind 'LISTING))
2168 (compiler-internal-error
2169 "asm-write-code, code stream not assembled"))
2170 (loop (cdr lst)))
2171 (begin
2172 (write-char (integer->char x))
2173 (loop (cdr lst))))))))))
2175 (define (asm-write-hex-file filename)
2176 (with-output-to-file filename
2177 (lambda ()
2179 (define (print-hex n)
2180 (display (string-ref "0123456789ABCDEF" n)))
2182 (define (print-byte n)
2183 (print-hex (quotient n 16))
2184 (print-hex (modulo n 16)))
2186 (define (print-line type addr bytes)
2187 (let ((n (length bytes))
2188 (addr-hi (quotient addr 256))
2189 (addr-lo (modulo addr 256)))
2190 (display ":")
2191 (print-byte n)
2192 (print-byte addr-hi)
2193 (print-byte addr-lo)
2194 (print-byte type)
2195 (for-each print-byte bytes)
2196 (let ((sum
2197 (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
2198 (print-byte sum)
2199 (newline))))
2201 (let loop ((lst (cdr asm-code-stream))
2202 (pos asm-start-pos)
2203 (rev-bytes '()))
2204 (if (not (null? lst))
2205 (let ((x (car lst)))
2206 (if (vector? x)
2207 (let ((kind (vector-ref x 0)))
2208 (if (not (eq? kind 'LISTING))
2209 (compiler-internal-error
2210 "asm-write-hex-file, code stream not assembled"))
2211 (loop (cdr lst)
2212 pos
2213 rev-bytes))
2214 (let ((new-pos
2215 (+ pos 1))
2216 (new-rev-bytes
2217 (cons x
2218 (if (= (modulo pos 16) 0)
2219 (begin
2220 (print-line 0
2221 (- pos (length rev-bytes))
2222 (reverse rev-bytes))
2223 '())
2224 rev-bytes))))
2225 (loop (cdr lst)
2226 new-pos
2227 new-rev-bytes))))
2228 (begin
2229 (if (not (null? rev-bytes))
2230 (print-line 0
2231 (- pos (length rev-bytes))
2232 (reverse rev-bytes)))
2233 (print-line 1 0 '())
2234 (if #t
2235 (begin
2236 (display (- pos asm-start-pos) ##stderr-port)
2237 (display " bytes\n" ##stderr-port)))))))))
2239 ;; Utilities.
2241 (define asm-start-pos #f) ; start position of the code stream
2242 (define asm-big-endian? #f) ; endianness to use
2243 (define asm-code-stream #f) ; current code stream
2245 (define (asm-make-stream) ; create an empty stream
2246 (let ((x (cons '() '())))
2247 (set-car! x x)
2248 x))
2250 (define (asm-code-extend item) ; add an item at the end of current code stream
2251 (let* ((stream asm-code-stream)
2252 (tail (car stream))
2253 (cell (cons item '())))
2254 (set-cdr! tail cell)
2255 (set-car! stream cell)))
2257 (define (asm-pass1) ; construct fixup list and make first label assignment
2258 (let loop ((curr (cdr asm-code-stream))
2259 (fixup-lst '())
2260 (span 0)
2261 (pos asm-start-pos))
2262 (if (null? curr)
2263 (reverse fixup-lst)
2264 (let ((x (car curr)))
2265 (if (vector? x)
2266 (let ((kind (vector-ref x 0)))
2267 (cond ((eq? kind 'LABEL)
2268 (vector-set! x 1 pos) ; first approximation of position
2269 (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
2270 ((eq? kind 'DEFERRED)
2271 (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos))
2272 (else
2273 (loop (cdr curr) fixup-lst span pos))))
2274 (loop (cdr curr) fixup-lst (+ span 1) (+ pos 1)))))))
2276 ;(##declare (generic))
2278 (define (asm-bits-0-to-7 n) ; return bits 0 to 7 of a signed integer
2279 (modulo n #x100))
2281 (define (asm-bits-8-and-up n) ; return bits 8 and up of a signed integer
2282 (if (>= n 0)
2283 (quotient n #x100)
2284 (- (quotient (+ n 1) #x100) 1)))
2286 (define (asm-bits-16-and-up n) ; return bits 16 and up of a signed integer
2287 (if (>= n 0)
2288 (quotient n #x10000)
2289 (- (quotient (+ n 1) #x10000) 1)))
2291 (define (asm-bits-32-and-up n) ; return bits 32 and up of a signed integer
2292 (if (>= n 0)
2293 (quotient n #x100000000)
2294 (- (quotient (+ n 1) #x100000000) 1)))
2296 ; The following procedures convert floating point numbers into their
2297 ; machine representation. They perform bignum and flonum arithmetic.
2299 (define (asm-float->inexact-exponential-format x)
2301 (define (exp-form-pos x y i)
2302 (let ((i*2 (+ i i)))
2303 (let ((z (if (and (not (< asm-ieee-e-bias i*2))
2304 (not (< x y)))
2305 (exp-form-pos x (* y y) i*2)
2306 (cons x 0))))
2307 (let ((a (car z)) (b (cdr z)))
2308 (let ((i+b (+ i b)))
2309 (if (and (not (< asm-ieee-e-bias i+b))
2310 (not (< a y)))
2311 (begin
2312 (set-car! z (/ a y))
2313 (set-cdr! z i+b)))
2314 z)))))
2316 (define (exp-form-neg x y i)
2317 (let ((i*2 (+ i i)))
2318 (let ((z (if (and (< i*2 asm-ieee-e-bias-minus-1)
2319 (< x y))
2320 (exp-form-neg x (* y y) i*2)
2321 (cons x 0))))
2322 (let ((a (car z)) (b (cdr z)))
2323 (let ((i+b (+ i b)))
2324 (if (and (< i+b asm-ieee-e-bias-minus-1)
2325 (< a y))
2326 (begin
2327 (set-car! z (/ a y))
2328 (set-cdr! z i+b)))
2329 z)))))
2331 (define (exp-form x)
2332 (if (< x asm-inexact-+1)
2333 (let ((z (exp-form-neg x asm-inexact-+1/2 1)))
2334 (set-car! z (* asm-inexact-+2 (car z)))
2335 (set-cdr! z (- -1 (cdr z)))
2336 z)
2337 (exp-form-pos x asm-inexact-+2 1)))
2339 (if (negative? x)
2340 (let ((z (exp-form (- asm-inexact-0 x))))
2341 (set-car! z (- asm-inexact-0 (car z)))
2342 z)
2343 (exp-form x)))
2345 (define (asm-float->exact-exponential-format x)
2346 (let ((z (asm-float->inexact-exponential-format x)))
2347 (let ((y (car z)))
2348 (cond ((not (< y asm-inexact-+2))
2349 (set-car! z asm-ieee-+m-min)
2350 (set-cdr! z asm-ieee-e-bias-plus-1))
2351 ((not (< asm-inexact--2 y))
2352 (set-car! z asm-ieee--m-min)
2353 (set-cdr! z asm-ieee-e-bias-plus-1))
2354 (else
2355 (set-car! z
2356 (truncate (inexact->exact (* (car z) asm-inexact-m-min))))))
2357 (set-cdr! z (- (cdr z) asm-ieee-m-bits))
2358 z)))
2360 (define (asm-float->bits x) ; returns the 64 bit integer encoding the float "x"
2362 (define (bits a b)
2363 (if (< a asm-ieee-+m-min)
2364 a
2365 (+ (- a asm-ieee-+m-min)
2366 (* (+ (+ b asm-ieee-m-bits) asm-ieee-e-bias)
2367 asm-ieee-+m-min))))
2369 (let ((z (asm-float->exact-exponential-format x)))
2370 (let ((a (car z)) (b (cdr z)))
2371 (if (negative? a)
2372 (+ asm-ieee-sign-bit (bits (- 0 a) b))
2373 (bits a b)))))
2375 ; Parameters for ANSI-IEEE Std 754-1985 representation of
2376 ; doubles (i.e. 64 bit floating point numbers):
2378 (define asm-ieee-m-bits 52)
2379 (define asm-ieee-e-bits 11)
2380 (define asm-ieee-+m-min 4503599627370496) ; (expt 2 asm-ieee-m-bits)
2381 (define asm-ieee--m-min -4503599627370496) ; (- asm-ieee-+m-min)
2382 (define asm-ieee-sign-bit #x8000000000000000); (expt 2 (+ asm-ieee-e-bits asm-ieee-m-bits))
2384 (define asm-ieee-e-bias 1023) ; (- (expt 2 (- asm-ieee-e-bits 1)) 1)
2385 (define asm-ieee-e-bias-plus-1 1024) ; (+ asm-ieee-e-bias 1)
2386 (define asm-ieee-e-bias-minus-1 1022) ; (- asm-ieee-e-bias 1)
2388 (define asm-inexact-m-min (exact->inexact asm-ieee-+m-min))
2389 (define asm-inexact-+2 (exact->inexact 2))
2390 (define asm-inexact--2 (exact->inexact -2))
2391 (define asm-inexact-+1 (exact->inexact 1))
2392 (define asm-inexact-+1/2 (exact->inexact (/ 1 2)))
2393 (define asm-inexact-0 (exact->inexact 0))
2395 ;------------------------------------------------------------------------------
2397 (define min-fixnum-encoding 3)
2398 (define min-fixnum -5)
2399 (define max-fixnum 40)
2400 (define min-rom-encoding (+ min-fixnum-encoding (- max-fixnum min-fixnum) 1))
2401 (define min-ram-encoding 128)
2402 (define max-ram-encoding 255)
2404 (define code-start #x2000)
2406 (define (predef-constants)
2407 (list))
2409 (define (predef-globals)
2410 (list))
2412 (define (encode-direct obj)
2413 (cond ((eq? obj #f)
2414 0)
2415 ((eq? obj #t)
2416 1)
2417 ((eq? obj '())
2418 2)
2419 ((and (integer? obj)
2420 (exact? obj)
2421 (>= obj min-fixnum)
2422 (<= obj max-fixnum))
2423 (+ obj (- min-fixnum-encoding min-fixnum)))
2424 (else
2425 #f)))
2427 (define (translate-constant obj)
2428 (if (char? obj)
2429 (char->integer obj)
2430 obj))
2432 (define (encode-constant obj constants)
2433 (let ((o (translate-constant obj)))
2434 (let ((e (encode-direct o)))
2435 (if e
2436 e
2437 (let ((x (assq o constants)))
2438 (if x
2439 (vector-ref (cdr x) 0)
2440 (compiler-error "unknown object" obj)))))))
2442 (define (add-constant obj constants from-code? cont)
2443 (let ((o (translate-constant obj)))
2444 (let ((e (encode-direct o)))
2445 (if e
2446 (cont constants)
2447 (let ((x (assq o constants)))
2448 (if x
2449 (begin
2450 (if from-code?
2451 (vector-set! (cdr x) 2 (+ (vector-ref (cdr x) 2) 1)))
2452 (cont constants))
2453 (let* ((descr
2454 (vector #f
2455 (asm-make-label 'constant)
2456 (if from-code? 1 0)
2457 #f))
2458 (new-constants
2459 (cons (cons o descr)
2460 constants)))
2461 (cond ((pair? o)
2462 (add-constants (list (car o) (cdr o))
2463 new-constants
2464 cont))
2465 ((symbol? o)
2466 (cont new-constants))
2467 ((string? o)
2468 (let ((chars (map char->integer (string->list o))))
2469 (vector-set! descr 3 chars)
2470 (add-constant chars
2471 new-constants
2472 #f
2473 cont)))
2474 ((vector? o)
2475 (let ((elems (vector->list o)))
2476 (vector-set! descr 3 elems)
2477 (add-constant elems
2478 new-constants
2479 #f
2480 cont)))
2482 (else
2483 (cont new-constants))))))))))
2485 (define (add-constants objs constants cont)
2486 (if (null? objs)
2487 (cont constants)
2488 (add-constant (car objs)
2489 constants
2490 #f
2491 (lambda (new-constants)
2492 (add-constants (cdr objs)
2493 new-constants
2494 cont)))))
2496 (define (add-global var globals cont)
2497 (let ((x (assq var globals)))
2498 (if x
2499 (cont globals)
2500 (let ((new-globals
2501 (cons (cons var (length globals))
2502 globals)))
2503 (cont new-globals)))))
2505 (define (sort-constants constants)
2506 (let ((csts
2507 (sort-list constants
2508 (lambda (x y)
2509 (> (vector-ref (cdr x) 2)
2510 (vector-ref (cdr y) 2))))))
2511 (let loop ((i min-rom-encoding)
2512 (lst csts))
2513 (if (null? lst)
2514 (if (> i min-ram-encoding)
2515 (compiler-error "too many constants")
2516 csts)
2517 (begin
2518 (vector-set! (cdr (car lst)) 0 i)
2519 (loop (+ i 1)
2520 (cdr lst)))))))
2522 (define assemble
2523 (lambda (code hex-filename)
2524 (let loop1 ((lst code)
2525 (constants (predef-constants))
2526 (globals (predef-globals))
2527 (labels (list)))
2528 (if (pair? lst)
2530 (let ((instr (car lst)))
2531 (cond ((number? instr)
2532 (loop1 (cdr lst)
2533 constants
2534 globals
2535 (cons (cons instr (asm-make-label 'label))
2536 labels)))
2537 ((eq? (car instr) 'push-constant)
2538 (add-constant (cadr instr)
2539 constants
2540 #t
2541 (lambda (new-constants)
2542 (loop1 (cdr lst)
2543 new-constants
2544 globals
2545 labels))))
2546 ((memq (car instr) '(push-global set-global))
2547 (add-global (cadr instr)
2548 globals
2549 (lambda (new-globals)
2550 (loop1 (cdr lst)
2551 constants
2552 new-globals
2553 labels))))
2554 (else
2555 (loop1 (cdr lst)
2556 constants
2557 globals
2558 labels))))
2560 (let ((constants (sort-constants constants)))
2562 (define (label-instr label opcode)
2563 (asm-at-assembly
2564 (lambda (self)
2565 2)
2566 (lambda (self)
2567 (let ((pos (- (asm-label-pos label) code-start)))
2568 (asm-8 (+ (quotient pos 256) opcode))
2569 (asm-8 (modulo pos 256))))))
2571 (define (push-constant n)
2572 (if (<= n 31)
2573 (asm-8 (+ #x00 n))
2574 (begin
2575 (asm-8 #xfc)
2576 (asm-8 n))))
2578 (define (push-stack n)
2579 (if (> n 31)
2580 (compiler-error "stack is too deep")
2581 (asm-8 (+ #x20 n))))
2583 (define (push-global n)
2584 (if (> n 15)
2585 (compiler-error "too many global variables")
2586 (asm-8 (+ #x40 n))))
2588 (define (set-global n)
2589 (if (> n 15)
2590 (compiler-error "too many global variables")
2591 (asm-8 (+ #x50 n))))
2593 (define (call n)
2594 (if (> n 15)
2595 (compiler-error "call has too many arguments")
2596 (asm-8 (+ #x60 n))))
2598 (define (jump n)
2599 (if (> n 15)
2600 (compiler-error "call has too many arguments")
2601 (asm-8 (+ #x70 n))))
2603 (define (call-toplevel label)
2604 (label-instr label #x80))
2606 (define (jump-toplevel label)
2607 (label-instr label #x90))
2609 (define (goto label)
2610 (label-instr label #xa0))
2612 (define (goto-if-false label)
2613 (label-instr label #xb0))
2615 (define (closure label)
2616 (label-instr label #xc0))
2618 (define (prim n)
2619 (asm-8 (+ #xd0 n)))
2621 (define (prim.number?) (prim 0))
2622 (define (prim.+) (prim 1))
2623 (define (prim.-) (prim 2))
2624 (define (prim.*) (prim 3))
2625 (define (prim.quotient) (prim 4))
2626 (define (prim.remainder) (prim 5))
2627 (define (prim.neg) (prim 6))
2628 (define (prim.=) (prim 7))
2629 (define (prim.<) (prim 8))
2630 (define (prim.<=) (prim 9))
2631 (define (prim.>) (prim 10))
2632 (define (prim.>=) (prim 11))
2633 (define (prim.pair?) (prim 12))
2634 (define (prim.cons) (prim 13))
2635 (define (prim.car) (prim 14))
2636 (define (prim.cdr) (prim 15))
2637 (define (prim.set-car!) (prim 16))
2638 (define (prim.set-cdr!) (prim 17))
2639 (define (prim.null?) (prim 18))
2640 (define (prim.eq?) (prim 19))
2641 (define (prim.not) (prim 20))
2642 (define (prim.get-cont) (prim 21))
2643 (define (prim.graft-to-cont) (prim 22))
2644 (define (prim.return-to-cont) (prim 23))
2645 (define (prim.halt) (prim 24))
2646 (define (prim.symbol?) (prim 25))
2647 (define (prim.string?) (prim 26))
2648 (define (prim.string->list) (prim 27))
2649 (define (prim.list->string) (prim 28))
2650 (define (prim.cast-int) (prim 29)) ;; ADDED
2652 (define (prim.print) (prim 32))
2653 (define (prim.clock) (prim 33))
2654 (define (prim.motor) (prim 34))
2655 (define (prim.led) (prim 35))
2656 (define (prim.getchar-wait) (prim 36))
2657 (define (prim.putchar) (prim 37))
2658 (define (prim.light) (prim 38))
2660 (define (prim.shift) (prim 45))
2661 (define (prim.pop) (prim 46))
2662 (define (prim.return) (prim 47))
2664 (define big-endian? #f)
2666 (asm-begin! code-start #f)
2668 (asm-8 #xfb)
2669 (asm-8 #xd7)
2670 (asm-8 (length constants))
2671 (asm-8 0)
2673 ; (pp (list constants: constants globals: globals))
2675 (for-each
2676 (lambda (x)
2677 (let* ((descr (cdr x))
2678 (label (vector-ref descr 1))
2679 (obj (car x)))
2680 (asm-label label)
2681 (cond ((and (integer? obj) (exact? obj))
2682 (asm-8 0)
2683 (asm-8 (bitwise-and (arithmetic-shift obj -16) 255))
2684 (asm-8 (bitwise-and (arithmetic-shift obj -8) 255))
2685 (asm-8 (bitwise-and obj 255)))
2686 ((pair? obj)
2687 (asm-8 2)
2688 (asm-8 (encode-constant (car obj) constants))
2689 (asm-8 (encode-constant (cdr obj) constants))
2690 (asm-8 0))
2691 ((symbol? obj)
2692 (asm-8 3)
2693 (asm-8 0)
2694 (asm-8 0)
2695 (asm-8 0))
2696 ((string? obj)
2697 (asm-8 4)
2698 (asm-8 (encode-constant (vector-ref descr 3) constants))
2699 (asm-8 0)
2700 (asm-8 0))
2701 ((vector? obj)
2702 (asm-8 5)
2703 (asm-8 (encode-constant (vector-ref descr 3) constants))
2704 (asm-8 0)
2705 (asm-8 0))
2706 (else
2707 (compiler-error "unknown object type" obj)))))
2708 constants)
2710 (let loop2 ((lst code))
2711 (if (pair? lst)
2712 (let ((instr (car lst)))
2714 (cond ((number? instr)
2715 (let ((label (cdr (assq instr labels))))
2716 (asm-label label)))
2718 ((eq? (car instr) 'entry)
2719 (let ((np (cadr instr))
2720 (rest? (caddr instr)))
2721 (asm-8 (if rest? (- np) np))))
2723 ((eq? (car instr) 'push-constant)
2724 (let ((n (encode-constant (cadr instr) constants)))
2725 (push-constant n)))
2727 ((eq? (car instr) 'push-stack)
2728 (push-stack (cadr instr)))
2730 ((eq? (car instr) 'push-global)
2731 (push-global (cdr (assq (cadr instr) globals))))
2733 ((eq? (car instr) 'set-global)
2734 (set-global (cdr (assq (cadr instr) globals))))
2736 ((eq? (car instr) 'call)
2737 (call (cadr instr)))
2739 ((eq? (car instr) 'jump)
2740 (jump (cadr instr)))
2742 ((eq? (car instr) 'call-toplevel)
2743 (let ((label (cdr (assq (cadr instr) labels))))
2744 (call-toplevel label)))
2746 ((eq? (car instr) 'jump-toplevel)
2747 (let ((label (cdr (assq (cadr instr) labels))))
2748 (jump-toplevel label)))
2750 ((eq? (car instr) 'goto)
2751 (let ((label (cdr (assq (cadr instr) labels))))
2752 (goto label)))
2754 ((eq? (car instr) 'goto-if-false)
2755 (let ((label (cdr (assq (cadr instr) labels))))
2756 (goto-if-false label)))
2758 ((eq? (car instr) 'closure)
2759 (let ((label (cdr (assq (cadr instr) labels))))
2760 (closure label)))
2762 ((eq? (car instr) 'prim)
2763 (case (cadr instr)
2764 ((#%number?) (prim.number?))
2765 ((#%+) (prim.+))
2766 ((#%-) (prim.-))
2767 ((#%*) (prim.*))
2768 ((#%quotient) (prim.quotient))
2769 ((#%remainder) (prim.remainder))
2770 ((#%neg) (prim.neg))
2771 ((#%=) (prim.=))
2772 ((#%<) (prim.<))
2773 ((#%<=) (prim.<=))
2774 ((#%>) (prim.>))
2775 ((#%>=) (prim.>=))
2776 ((#%pair?) (prim.pair?))
2777 ((#%cons) (prim.cons))
2778 ((#%car) (prim.car))
2779 ((#%cdr) (prim.cdr))
2780 ((#%set-car!) (prim.set-car!))
2781 ((#%set-cdr!) (prim.set-cdr!))
2782 ((#%null?) (prim.null?))
2783 ((#%eq?) (prim.eq?))
2784 ((#%not) (prim.not))
2785 ((#%get-cont) (prim.get-cont))
2786 ((#%graft-to-cont) (prim.graft-to-cont))
2787 ((#%return-to-cont) (prim.return-to-cont))
2788 ((#%halt) (prim.halt))
2789 ((#%symbol?) (prim.symbol?))
2790 ((#%string?) (prim.string?))
2791 ((#%string->list) (prim.string->list))
2792 ((#%list->string) (prim.list->string))
2793 ((#%cast-int) (prim.cast-int)) ;; ADDED
2795 ((#%print) (prim.print))
2796 ((#%clock) (prim.clock))
2797 ((#%motor) (prim.motor))
2798 ((#%led) (prim.led))
2799 ((#%getchar-wait) (prim.getchar-wait))
2800 ((#%putchar) (prim.putchar))
2801 ((#%light) (prim.light))
2802 (else
2803 (compiler-error "unknown primitive" (cadr instr)))))
2805 ((eq? (car instr) 'return)
2806 (prim.return))
2808 ((eq? (car instr) 'pop)
2809 (prim.pop))
2811 ((eq? (car instr) 'shift)
2812 (prim.shift))
2814 (else
2815 (compiler-error "unknown instruction" instr)))
2817 (loop2 (cdr lst)))))
2819 (asm-assemble)
2821 (asm-write-hex-file hex-filename)
2823 (asm-end!))))))
2825 (define execute
2826 (lambda (hex-filename)
2827 '
2828 (if #f
2829 (begin
2830 (shell-command "gcc -o picobit-vm picobit-vm.c")
2831 (shell-command (string-append "./picobit-vm " hex-filename)))
2832 (shell-command (string-append "./robot . 1 " hex-filename)))))
2834 (define (sort-list l <?)
2836 (define (mergesort l)
2838 (define (merge l1 l2)
2839 (cond ((null? l1) l2)
2840 ((null? l2) l1)
2841 (else
2842 (let ((e1 (car l1)) (e2 (car l2)))
2843 (if (<? e1 e2)
2844 (cons e1 (merge (cdr l1) l2))
2845 (cons e2 (merge l1 (cdr l2))))))))
2847 (define (split l)
2848 (if (or (null? l) (null? (cdr l)))
2849 l
2850 (cons (car l) (split (cddr l)))))
2852 (if (or (null? l) (null? (cdr l)))
2853 l
2854 (let* ((l1 (mergesort (split l)))
2855 (l2 (mergesort (split (cdr l)))))
2856 (merge l1 l2))))
2858 (mergesort l))
2860 ;------------------------------------------------------------------------------
2862 (define compile
2863 (lambda (filename)
2864 (let* ((node (parse-file filename))
2865 (hex-filename
2866 (string-append
2867 (path-strip-extension filename)
2868 ".hex")))
2870 ; (pp (node->expr node))
2872 (let ((ctx (comp-none node (make-init-context))))
2873 (let ((prog (linearize (optimize-code (context-code ctx)))))
2874 ; (pp (list code: prog env: (context-env ctx)))
2875 (assemble prog hex-filename)
2876 (execute hex-filename))))))
2879 (define main
2880 (lambda (filename)
2881 (compile filename)))
2883 ;------------------------------------------------------------------------------
2885 '
2886 (define (asm-write-hex-file filename)
2887 (with-output-to-file filename
2888 (lambda ()
2890 (define (print-hex n)
2891 (display (string-ref "0123456789ABCDEF" n)))
2893 (define (print-byte n)
2894 (display ", 0x")
2895 (print-hex (quotient n 16))
2896 (print-hex (modulo n 16)))
2898 (define (print-line type addr bytes)
2899 (let ((n (length bytes))
2900 (addr-hi (quotient addr 256))
2901 (addr-lo (modulo addr 256)))
2902 ; (display ":")
2903 ; (print-byte n)
2904 ; (print-byte addr-hi)
2905 ; (print-byte addr-lo)
2906 ; (print-byte type)
2907 (for-each print-byte bytes)
2908 (let ((sum
2909 (modulo (- (apply + n addr-hi addr-lo type bytes)) 256)))
2910 ; (print-byte sum)
2911 (newline))))
2913 (let loop ((lst (cdr asm-code-stream))
2914 (pos asm-start-pos)
2915 (rev-bytes '()))
2916 (if (not (null? lst))
2917 (let ((x (car lst)))
2918 (if (vector? x)
2919 (let ((kind (vector-ref x 0)))
2920 (if (not (eq? kind 'LISTING))
2921 (compiler-internal-error
2922 "asm-write-hex-file, code stream not assembled"))
2923 (loop (cdr lst)
2924 pos
2925 rev-bytes))
2926 (let ((new-pos
2927 (+ pos 1))
2928 (new-rev-bytes
2929 (cons x
2930 (if (= (modulo pos 8) 0)
2931 (begin
2932 (print-line 0
2933 (- pos (length rev-bytes))
2934 (reverse rev-bytes))
2935 '())
2936 rev-bytes))))
2937 (loop (cdr lst)
2938 new-pos
2939 new-rev-bytes))))
2940 (begin
2941 (if (not (null? rev-bytes))
2942 (print-line 0
2943 (- pos (length rev-bytes))
2944 (reverse rev-bytes)))
2945 (print-line 1 0 '())))))))