| blob | 485f2b1385d7c13ab875feeeb51b8c4b687ea00a |
1 ;;;============================================================================
3 ;;; File: "_ptree2.scm"
5 ;;; Copyright (c) 1994-2011 by Marc Feeley, All Rights Reserved.
7 (include "fixnum.scm")
9 (include-adt "_envadt.scm")
10 (include-adt "_gvmadt.scm")
11 (include-adt "_ptreeadt.scm")
12 (include-adt "_sourceadt.scm")
14 '(begin;**********brad
15 (##include "../gsc/_utilsadt.scm")
16 (##include "../gsc/_envadt.scm")
17 (##include "../gsc/_ptree1adt.scm")
18 (##include "../gsc/_hostadt.scm")
19 )
21 ;;;----------------------------------------------------------------------------
22 ;;
23 ;; Parse tree manipulation module: (part 2)
24 ;; ------------------------------
26 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
28 (define (normalize-program ptrees)
29 (let* ((lst1 (expand-primitive-calls ptrees))
30 (lst2 (assignment-convert lst1))
31 (lst3 (beta-reduce lst2))
32 (lst4 (lambda-lift lst3)))
33 lst4))
35 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
37 ;; (delete-ptree ptree) removes parse tree 'ptree' from program and updates
38 ;; references and assignments to variables.
40 (define (delete-ptree ptree)
42 (cond ((ref? ptree)
43 (let ((var (ref-var ptree)))
44 (var-refs-set! var (ptset-remove (var-refs var) ptree))))
46 ((set? ptree)
47 (let ((var (set-var ptree)))
48 (var-sets-set! var (ptset-remove (var-sets var) ptree))))
50 ((def? ptree)
51 (let ((var (def-var ptree)))
52 (var-sets-set! var (ptset-remove (var-sets var) ptree)))))
54 (for-each delete-ptree (node-children ptree)))
56 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
58 ;; (clone-ptree ptree) returns a fresh copy of 'ptree'. All the
59 ;; bound variables (i.e. not free variables) in ptree are also copied.
60 ;; It is assumed that 'ptree' has already been assignment-converted.
62 (define (clone-ptree ptree)
63 (cp ptree '()))
65 (define (cp ptree substs)
67 (define (rename-var var)
68 (let ((x (assq var substs)))
69 (if x (cdr x) var)))
71 (cond ((cst? ptree)
72 (new-cst (node-source ptree) (node-env ptree)
73 (cst-val ptree)))
75 ((ref? ptree)
76 (let ((var (rename-var (ref-var ptree))))
77 (new-ref (node-source ptree) (node-env ptree)
78 var)))
80 ((set? ptree)
81 (let ((var (rename-var (set-var ptree))))
82 (new-set (node-source ptree) (node-env ptree)
83 var
84 (cp (set-val ptree) substs))))
86 ((def? ptree) ; guaranteed to be a toplevel definition
87 (new-def (node-source ptree) (node-env ptree)
88 (def-var ptree)
89 (cp (def-val ptree) substs)))
91 ((tst? ptree)
92 (new-tst (node-source ptree) (node-env ptree)
93 (cp (tst-pre ptree) substs)
94 (cp (tst-con ptree) substs)
95 (cp (tst-alt ptree) substs)))
97 ((conj? ptree)
98 (new-conj (node-source ptree) (node-env ptree)
99 (cp (conj-pre ptree) substs)
100 (cp (conj-alt ptree) substs)))
102 ((disj? ptree)
103 (new-disj (node-source ptree) (node-env ptree)
104 (cp (disj-pre ptree) substs)
105 (cp (disj-alt ptree) substs)))
107 ((prc? ptree)
108 (let* ((parms (prc-parms ptree))
109 (vars (clone-vars parms)))
110 (new-prc (node-source ptree) (node-env ptree)
111 (prc-name ptree)
112 (prc-c-name ptree)
113 vars
114 (prc-opts ptree)
115 (prc-keys ptree)
116 (prc-rest? ptree)
117 (cp (prc-body ptree)
118 (append (pair-up parms vars) substs)))))
120 ((app? ptree)
121 (let ((oper (app-oper ptree))
122 (args (app-args ptree)))
123 (if (and (prc? oper) ; applying a lambda-expr is like a 'let'
124 (prc-req-and-opt-parms-only? oper)
125 (= (length (prc-parms oper)) (length args)))
126 (let* ((parms (prc-parms oper))
127 (vars (clone-vars parms))
128 (new-substs (append (pair-up parms vars) substs)))
129 (new-let ptree
130 oper
131 vars
132 (map (lambda (x) (cp x new-substs)) args)
133 (cp (prc-body oper) new-substs)))
134 (new-call (node-source ptree) (node-env ptree)
135 (cp (app-oper ptree) substs)
136 (map (lambda (x) (cp x substs)) (app-args ptree))))))
138 ((fut? ptree)
139 (new-fut (node-source ptree) (node-env ptree)
140 (cp (fut-val ptree) substs)))
142 (else
143 (compiler-internal-error "cp, unknown parse tree node type"))))
145 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
146 ;;
147 ;; Expansion of primitive calls
148 ;; ----------------------------
150 ;; (expand-primitive-calls lst) takes a list of parse-trees and returns
151 ;; a list where each parse-tree has been replaced with an equivalent
152 ;; parse-tree where some calls to primitive procedures have been
153 ;; expanded into an equivalent, but probably faster, Scheme expression.
155 (define (expand-primitive-calls lst)
156 (map epc lst))
158 (define (epc ptree)
160 (cond ((or (cst? ptree)
161 (set? ptree)
162 (def? ptree) ; guaranteed to be a toplevel definition
163 (tst? ptree)
164 (conj? ptree)
165 (disj? ptree)
166 (prc? ptree)
167 (fut? ptree))
168 (node-children-set! ptree
169 (map epc
170 (node-children ptree)))
171 ptree)
173 ((ref? ptree)
174 (let ((proc (global-proc-obj ptree)))
175 (if proc
176 (let ((proc-node
177 (new-cst (node-source ptree) (node-env ptree)
178 proc)))
179 (delete-ptree ptree)
180 proc-node)
181 ptree)))
183 ((app? ptree)
184 (let* ((oper
185 (app-oper ptree))
186 (args
187 (map epc (app-args ptree)))
188 (new-oper
189 (cond ((ref? oper)
190 (let ((var (ref-var oper)))
191 (if (global? var)
192 (let* ((name
193 (var-name var))
194 (proc
195 (target.prim-info name))
196 (spec
197 (specialize-proc proc args (node-env oper)))
198 (source
199 (node-source ptree))
200 (env
201 (node-env ptree)))
203 (define (generate-spec-call vars)
204 (new-call source (add-not-inline-primitives env)
205 (new-cst source env
206 spec)
207 (gen-var-refs source env vars)))
209 (define (generate-original-call vars)
210 (new-call source (add-not-inline-primitives env)
211 (new-ref (node-source oper) (node-env oper)
212 var)
213 (gen-var-refs source env vars)))
215 (define (generate-run-time-binding-test gen-body)
216 (let ((vars (gen-temp-vars source args)))
217 (gen-prc source env
218 vars
219 (new-tst source env
220 (gen-eq-proc source env
221 (new-ref
222 (node-source oper)
223 (node-env oper)
224 var)
225 proc)
226 (gen-body vars)
227 (generate-original-call vars)))))
229 (if (and spec
230 (inline-primitive? name env)
231 (or ((proc-obj-inlinable? spec) env)
232 ((proc-obj-expandable? spec) env)))
233 (let* ((std?
234 (standard-proc-obj proc
235 name
236 (node-env oper)))
237 (rtb?
238 (run-time-binding? name
239 (node-env oper)))
240 (new-oper
241 (if ((proc-obj-inlinable? spec) env)
242 (cond (std?
243 (new-cst source env
244 spec))
245 (rtb?
246 (generate-run-time-binding-test
247 generate-spec-call))
248 (else
249 #f))
250 (and (or std?
251 rtb?)
252 (let ((x
253 ((proc-obj-expand spec)
254 ptree
255 oper
256 args
257 (if (eq? proc spec)
258 generate-original-call
259 generate-spec-call)
260 (and (not std?)
261 (eq? proc spec)
262 (lambda ()
263 (gen-eq-proc source env
264 (new-ref
265 (node-source oper)
266 (node-env oper)
267 var)
268 proc))))))
269 (if x
270 (if (and (not std?)
271 (not (eq? proc spec)))
272 (generate-run-time-binding-test
273 (lambda (vars)
274 (new-call source env
275 x
276 (gen-var-refs source env vars))))
277 x)
278 (and std?
279 (new-cst source env
280 spec))))))))
281 (if new-oper
282 (begin
283 (delete-ptree oper)
284 (epc new-oper))
285 (epc oper)))
286 (epc oper)))
287 (epc oper))))
289 ((and (cst? oper)
290 (proc-obj? (cst-val oper)))
291 (let* ((proc
292 (cst-val oper))
293 (spec
294 (specialize-proc proc args (node-env oper)))
295 (source
296 (node-source ptree))
297 (env
298 (node-env ptree))
299 (x
300 (and spec
301 (inline-primitive? (proc-obj-name spec) env)
302 ((proc-obj-expandable? spec) env)
303 ((proc-obj-expand spec)
304 ptree
305 oper
306 args
307 (lambda (vars)
308 (new-call
309 source
310 (add-not-inline-primitives env)
311 (new-cst source env
312 spec)
313 (gen-var-refs source env vars)))
314 #f))))
315 (epc (or x oper))))
317 (else
318 (epc oper)))))
320 (node-children-set! ptree
321 (cons new-oper
322 args))
324 ptree))
326 (else
327 (compiler-internal-error "epc, unknown parse tree node type"))))
329 (define (gen-prc source env params body)
330 (new-prc source env #f #f params '() #f #f body))
332 (define (gen-disj-multi source env nodes)
333 (if (pair? (cdr nodes))
334 (new-disj source env
335 (car nodes)
336 (gen-disj-multi source env (cdr nodes)))
337 (car nodes)))
339 (define (gen-uniform-type-checks source env vars type-check tail)
341 (define (loop result lst)
342 (if (pair? lst)
343 (loop (new-conj source env
344 (type-check (car lst))
345 result)
346 (cdr lst))
347 result))
349 (cond (tail
350 (loop tail vars))
351 ((pair? vars)
352 (loop (type-check (car vars)) (cdr vars)))
353 (else
354 #f)))
356 (define (gen-temp-vars source args)
357 (let loop ((args args) (rev-vars '()))
358 (if (null? args)
359 (reverse rev-vars)
360 (loop (cdr args)
361 (cons (new-temp-variable source 'temp)
362 rev-vars)))))
364 (define (gen-var-refs source env vars)
365 (map (lambda (var)
366 (new-ref source env
367 var))
368 vars))
370 (define (gen-call-prim-vars source env prim vars)
371 (gen-call-prim source env
372 prim
373 (gen-var-refs source env vars)))
375 (define (gen-call-prim source env prim args)
376 (new-call source (add-not-safe env)
377 (new-cst source env
378 (target.prim-info prim))
379 args))
381 (define (gen-eq-proc source env arg proc)
382 (gen-call-prim source env
383 '##eq?;;;;;;;;;;
384 (list
385 arg
386 (new-cst source env
387 proc))))
389 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
390 ;;
391 ;; Assignment conversion:
392 ;; ---------------------
394 ;; (assignment-convert lst) takes a list of parse-trees and returns a
395 ;; list where each parse-tree has been replaced with an equivalent
396 ;; parse-tree containing no assignments to non-global variables. In
397 ;; the converted parse-tree, 'box' objects are used to implement mutable
398 ;; variables and calls to the procedures:
399 ;;
400 ;; ##box
401 ;; ##unbox
402 ;; ##set-box!
403 ;;
404 ;; are added to create and access the boxes.
406 (define (assignment-convert lst)
407 (map (lambda (ptree) (ac ptree '()))
408 lst))
410 (define (ac ptree mut)
412 (cond ((cst? ptree)
413 ptree)
415 ((ref? ptree)
416 (let ((var (ref-var ptree)))
417 (if (global? var)
418 ptree
419 (let ((x (assq var mut)))
420 (if x
421 (let ((source (node-source ptree)))
422 (var-refs-set! var (ptset-remove (var-refs var) ptree))
423 (gen-call-prim source (node-env ptree)
424 **unbox-sym
425 (list (new-ref source (node-env ptree) (cdr x)))))
426 ptree)))))
428 ((set? ptree)
429 (let ((var (set-var ptree))
430 (source (node-source ptree))
431 (val (ac (set-val ptree) mut)))
432 (if (global? var)
433 (begin
434 (var-sets-set! var (ptset-remove (var-sets var) ptree))
435 (new-set source (node-env ptree)
436 var
437 val))
438 (gen-call-prim source (node-env ptree)
439 **set-box!-sym
440 (list (new-ref source (node-env ptree) (cdr (assq var mut)))
441 val)))))
443 ((def? ptree) ; guaranteed to be a toplevel definition
444 (let ((var (def-var ptree))
445 (val (ac (def-val ptree) mut)))
446 (var-sets-set! var (ptset-remove (var-sets var) ptree))
447 (new-def (node-source ptree) (node-env ptree)
448 var
449 val)))
451 ((tst? ptree)
452 (new-tst (node-source ptree) (node-env ptree)
453 (ac (tst-pre ptree) mut)
454 (ac (tst-con ptree) mut)
455 (ac (tst-alt ptree) mut)))
457 ((conj? ptree)
458 (new-conj (node-source ptree) (node-env ptree)
459 (ac (conj-pre ptree) mut)
460 (ac (conj-alt ptree) mut)))
462 ((disj? ptree)
463 (new-disj (node-source ptree) (node-env ptree)
464 (ac (disj-pre ptree) mut)
465 (ac (disj-alt ptree) mut)))
467 ((prc? ptree)
468 (ac-proc ptree mut))
470 ((app? ptree)
471 (let ((oper (app-oper ptree))
472 (args (app-args ptree)))
473 (if (and (prc? oper) ; applying a lambda-expr is like a 'let'
474 (prc-req-and-opt-parms-only? oper)
475 (= (length (prc-parms oper)) (length args)))
476 (ac-let ptree mut)
477 (new-call (node-source ptree) (node-env ptree)
478 (ac oper mut)
479 (map (lambda (x) (ac x mut)) args)))))
481 ((fut? ptree)
482 (new-fut (node-source ptree) (node-env ptree)
483 (ac (fut-val ptree) mut)))
485 (else
486 (compiler-internal-error "ac, unknown parse tree node type"))))
488 (define (ac-proc ptree mut)
489 (let* ((mut-parms (ac-mutables (prc-parms ptree)))
490 (cloned-mut-parms (clone-vars mut-parms)))
492 (for-each (lambda (var) (var-sets-set! var (ptset-empty)))
493 mut-parms)
495 (for-each (lambda (var) (var-boxed?-set! var #t))
496 cloned-mut-parms)
498 (new-prc (node-source ptree) (node-env ptree)
499 (prc-name ptree)
500 (prc-c-name ptree)
501 (prc-parms ptree)
502 (prc-opts ptree)
503 (prc-keys ptree)
504 (prc-rest? ptree)
505 (new-let ptree
506 ptree
507 cloned-mut-parms
508 (map (lambda (var)
509 (gen-call-prim (var-source var) (node-env ptree)
510 **box-sym
511 (list (new-ref (var-source var)
512 (node-env ptree)
513 var))))
514 mut-parms)
515 (ac (prc-body ptree)
516 (append (pair-up mut-parms cloned-mut-parms) mut))))))
518 (define (ac-let ptree mut)
519 (let* ((proc (app-oper ptree))
520 (vals (app-args ptree))
521 (vars (prc-parms proc))
522 (vals-fv (varset-union-multi (map bound-free-variables vals)))
523 (mut-parms (ac-mutables vars))
524 (cloned-mut-parms (clone-vars mut-parms))
525 (mut (append (pair-up mut-parms cloned-mut-parms) mut)))
527 (for-each (lambda (var) (var-sets-set! var (ptset-empty)))
528 mut-parms)
530 (for-each (lambda (var) (var-boxed?-set! var #t))
531 cloned-mut-parms)
533 (let loop ((l1 vars)
534 (l2 vals)
535 (new-vars '())
536 (new-vals '())
537 (new-body (ac (prc-body proc) mut)))
538 (if (null? l1)
540 (new-let ptree proc new-vars new-vals new-body)
542 (let ((var (car l1))
543 (val (car l2)))
545 (if (memq var mut-parms)
547 (let ((src (node-source val))
548 (env (node-env val))
549 (var* (cdr (assq var mut))))
551 (if (varset-member? var vals-fv)
553 (loop (cdr l1)
554 (cdr l2)
555 (cons var* new-vars)
556 (cons (gen-call-prim src env
557 **box-sym
558 (list (new-cst src env void-object)))
559 new-vals)
560 (new-seq src env
561 (gen-call-prim src env
562 **set-box!-sym
563 (list (new-ref src env var*)
564 (ac val mut)))
565 new-body))
567 (loop (cdr l1)
568 (cdr l2)
569 (cons var* new-vars)
570 (cons (gen-call-prim src env
571 **box-sym
572 (list (ac val mut)))
573 new-vals)
574 new-body)))
576 (loop (cdr l1)
577 (cdr l2)
578 (cons var new-vars)
579 (cons (ac val mut) new-vals)
580 new-body)))))))
582 (define (ac-mutables lst)
583 (keep mutable? lst))
585 (define (clone-vars vars)
586 (map (lambda (var)
587 (let ((cloned-var
588 (make-var (var-name var)
589 #t
590 (ptset-empty)
591 (ptset-empty)
592 (var-source var))))
593 (var-boxed?-set! cloned-var (var-boxed? var))
594 cloned-var))
595 vars))
597 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
598 ;;
599 ;; Beta-reduction:
600 ;; --------------
602 ;; (beta-reduce ptrees) takes a list of parse-trees and transforms
603 ;; each parse-tree with the following transformations:
604 ;;
605 ;; - constant propagation
606 ;; - copy propagation
607 ;; - useless variable elimination
608 ;;
609 ;; It is assumed that the parse-trees have already been assignment-converted.
611 (define beta-reduce #f);***************
613 (set! beta-reduce (lambda (ptrees)
615 (define (vars-with-duplicates->varset vars);********brad avoids this because list->set removes duplicates
616 (let loop ((set (varset-empty)) (lst vars))
617 (if (pair? lst)
618 (loop (varset-adjoin set (car lst)) (cdr lst))
619 set)))
621 (define (pass1) ; transform definitions in dependency order
622 (let* ((defs
623 (keep def? ptrees))
624 (defined-vars
625 (vars-with-duplicates->varset (map def-var (reverse defs))))
626 (depgraph
627 (map (lambda (var)
628 (make-gnode var
629 (varset-union-multi
630 (map (lambda (def)
631 (varset-intersection
632 defined-vars
633 (free-variables (def-val def))))
634 (keep def?
635 (ptset->list (var-sets var)))))))
636 (varset->list defined-vars)))
637 (order
638 (topological-sort
639 (transitive-closure depgraph))))
640 (for-each
641 (lambda (vars)
642 (for-each
643 (lambda (var)
644 (for-each
645 (lambda (def)
646 (node-children-set!
647 def
648 (list (br (def-val def) '() 'need #f))))
649 (keep def? (ptset->list (var-sets var)))))
650 (varset->list vars)))
651 order)))
653 (define (pass2) ; transform non-definitions from top to bottom
654 (let loop ((lst1 ptrees) (lst2 '()))
655 (if (pair? lst1)
656 (let ((ptree (car lst1)))
657 (cond ((not (core? (node-env ptree)))
658 (delete-ptree ptree)
659 (loop (cdr lst1) lst2))
660 ((def? ptree)
661 (loop (cdr lst1) (cons ptree lst2)))
662 (else
663 (loop (cdr lst1) (cons (br ptree
664 '()
665 'need
666 #f)
667 lst2)))))
668 (reverse lst2))))
670 (pass1)
671 (pass2))
672 )
674 (define (br ptree substs reason expansion-limit)
676 (cond ((cst? ptree)
677 (new-cst (node-source ptree) (node-env ptree)
678 (cst-val ptree)))
680 ((ref? ptree)
681 (let ((var (ref-var ptree)))
682 (var-refs-set! var (ptset-remove (var-refs var) ptree))
683 (let ((new-var (var-subst var substs)))
684 (let ((x (var-to-val new-var substs)))
685 (if (and x (or (cst? x) (ref? x)))
686 (clone-ptree x)
687 (new-ref (node-source ptree) (node-env ptree)
688 new-var))))))
690 ((set? ptree) ; variable guaranteed to be a global variable
691 (let ((var (set-var ptree))
692 (val (br (set-val ptree) substs 'need expansion-limit)))
693 (var-sets-set! var (ptset-remove (var-sets var) ptree))
694 (new-set (node-source ptree) (node-env ptree)
695 var
696 val)))
698 ((tst? ptree)
699 (let ((pre (br (tst-pre ptree) substs 'pred expansion-limit)))
700 (if (cst? pre)
701 (if (false-object? (cst-val pre))
702 (begin
703 (delete-ptree pre)
704 (delete-ptree (tst-con ptree))
705 (br (tst-alt ptree) substs reason expansion-limit))
706 (begin
707 (delete-ptree pre)
708 (delete-ptree (tst-alt ptree))
709 (br (tst-con ptree) substs reason expansion-limit)))
710 (new-tst (node-source ptree) (node-env ptree)
711 pre
712 (br (tst-con ptree) substs reason expansion-limit)
713 (br (tst-alt ptree) substs reason expansion-limit)))))
715 ((conj? ptree)
716 (let ((pre (br (conj-pre ptree) substs reason expansion-limit)))
717 (if (cst? pre)
718 (if (false-object? (cst-val pre))
719 (begin
720 (delete-ptree (conj-alt ptree))
721 pre)
722 (begin
723 (delete-ptree pre)
724 (br (conj-alt ptree) substs reason expansion-limit)))
725 (let ((alt (br (conj-alt ptree) substs reason expansion-limit)))
726 (cond ((and (cst? alt)
727 (false-object? (cst-val alt)))
728 (if (side-effects-impossible? pre)
729 (begin
730 ; (and X #f) => #f
731 (delete-ptree pre)
732 alt)
733 (begin
734 ; (and X #f) => (begin X #f)
735 ; this transform should be generalized
736 (new-seq (node-source ptree) (node-env ptree)
737 pre
738 alt))))
739 ((and (cst? alt)
740 (not (false-object? (cst-val alt)))
741 (eq? reason 'pred))
742 ; (if (and X non-#f) ...) => (if X ...)
743 (delete-ptree alt)
744 pre)
745 (else
746 (new-conj (node-source ptree) (node-env ptree)
747 pre
748 alt)))))))
750 ((disj? ptree)
751 (let ((pre (br (disj-pre ptree) substs reason expansion-limit)))
752 (if (cst? pre)
753 (if (false-object? (cst-val pre))
754 (begin
755 (delete-ptree pre)
756 (br (disj-alt ptree) substs reason expansion-limit))
757 (begin
758 (delete-ptree (disj-alt ptree))
759 pre))
760 (let ((alt (br (disj-alt ptree) substs reason expansion-limit)))
761 (if (and (cst? alt)
762 (false-object? (cst-val alt)))
763 (begin
764 ; (or X #f) => X
765 (delete-ptree alt)
766 pre)
767 (new-disj (node-source ptree) (node-env ptree)
768 pre
769 alt))))))
771 ((prc? ptree)
772 (new-prc (node-source ptree) (node-env ptree)
773 (prc-name ptree)
774 (prc-c-name ptree)
775 (prc-parms ptree)
776 (prc-opts ptree)
777 (prc-keys ptree)
778 (prc-rest? ptree)
779 (br (prc-body ptree) substs 'need expansion-limit)))
781 ((br-let? ptree)
782 (br-let ptree substs reason expansion-limit))
784 ((app? ptree)
785 (let ((oper (app-oper ptree))
786 (args (app-args ptree)))
787 (if (or (cst? oper) (ref? oper))
788 (let ((br-oper (br oper substs 'need expansion-limit)))
789 ; at this point (or (cst? br-oper) (ref? br-oper))
790 (or (br-app-inline ptree br-oper args substs reason expansion-limit)
791 (br-app-simplify ptree br-oper args substs reason expansion-limit)))
792 (br-app ptree oper args substs reason expansion-limit))))
794 ((fut? ptree)
795 (new-fut (node-source ptree) (node-env ptree)
796 (br (fut-val ptree) substs 'need expansion-limit)))
798 (else
799 (compiler-internal-error "br, unknown parse tree node type"))))
801 (define (var-subst var substs)
802 (if (null? substs)
803 var
804 (let ((couple (car substs)))
805 (if (eq? (car couple) var)
806 (if (ref? (cdr couple))
807 (var-subst (ref-var (cdr couple)) (cdr substs))
808 var)
809 (var-subst var (cdr substs))))))
811 (define (var-to-val var substs)
812 (if (global? var)
813 (global-single-def var)
814 (let ((x (assq var substs)))
815 (if x (cdr x) #f))))
817 (define (br-let? ptree)
818 (and (app? ptree)
819 (let ((oper (app-oper ptree))
820 (args (app-args ptree)))
821 (and (prc? oper) ; applying a lambda-expr is like a 'let'
822 (prc-req-and-opt-parms-only? oper)
823 (= (length (prc-parms oper)) (length args))))))
825 (define (br-app ptree oper args substs reason expansion-limit)
827 (if (and (br-let? oper)
828 (let ((body (prc-body (app-oper oper))))
829 (or (cst? body)
830 (and (ref? body)
831 (or (bound? (ref-var body))
832 (global-singly-bound? body))))))
834 ;; let-floating transformation when the code is of the
835 ;; form:
836 ;;
837 ;; ((let (...) var) E1 E2) -> (let (...) (var E1 E2))
839 (let ((proc (app-oper oper)))
840 (br (new-call (node-source oper) (node-env oper)
841 (new-prc (node-source proc) (node-env proc)
842 (prc-name proc)
843 (prc-c-name proc)
844 (prc-parms proc)
845 (prc-opts proc)
846 (prc-keys proc)
847 (prc-rest? proc)
848 (new-call (node-source ptree) (node-env ptree)
849 (prc-body proc)
850 args))
851 (app-args oper))
852 substs
853 reason
854 expansion-limit))
856 (new-call (node-source ptree) (node-env ptree)
857 (br oper substs 'need expansion-limit)
858 (map (lambda (arg) (br arg substs 'need expansion-limit)) args))))
860 (define (br-let ptree substs reason expansion-limit)
861 (let* ((proc
862 (app-oper ptree))
863 (vals
864 (app-args ptree))
865 (vars
866 (prc-parms proc))
867 (vars-varset
868 (list->varset vars))
869 (var-val-map
870 (pair-up vars vals))
871 (new-substs
872 (br-extend-substs vars vals substs))
873 (br-vals
874 (map (lambda (x) (br x new-substs 'need expansion-limit)) vals))
875 (new-substs2
876 (br-extend-substs vars br-vals substs))
877 (new-body
878 (br (prc-body proc) new-substs2 reason expansion-limit)))
880 (define (var->val var) (cdr (assq var var-val-map)))
882 (define (reachable-vars-from starting-point)
883 (let loop ((old-reachable-vars
884 (varset-empty))
885 (reachable-vars
886 (varset-intersection
887 vars-varset
888 starting-point)))
889 (if (varset-equal? reachable-vars old-reachable-vars)
890 reachable-vars
891 (loop reachable-vars
892 (varset-union-multi
893 (cons reachable-vars
894 (map (lambda (var)
895 (varset-intersection
896 vars-varset
897 (bound-free-variables (var->val var))))
898 (varset->list
899 (varset-difference reachable-vars
900 old-reachable-vars)))))))))
902 ; remove useless bindings
904 (let ((reachable-vars
905 (reachable-vars-from
906 (varset-union-multi
907 (cons (bound-free-variables new-body)
908 (map (lambda (br-val)
909 (if (prc? br-val)
910 (varset-empty) ; reachable only if called
911 (bound-free-variables br-val)))
912 br-vals))))))
913 (let loop ((l1 vars)
914 (l2 br-vals)
915 (new-vars '())
916 (new-vals '()))
917 (if (null? l1)
918 (new-let ptree
919 proc
920 (reverse new-vars)
921 (reverse new-vals)
922 new-body)
923 (let ((var (car l1))
924 (br-val (car l2)))
925 (if (and (not (varset-member? var reachable-vars))
926 (or (cst? br-val)
927 (ref? br-val)
928 (prc? br-val)))
929 (begin
930 (delete-ptree br-val)
931 (loop (cdr l1)
932 (cdr l2)
933 new-vars
934 new-vals))
935 (loop (cdr l1)
936 (cdr l2)
937 (cons var new-vars)
938 (cons br-val new-vals)))))))))
940 (define (br-extend-substs vars vals substs)
941 (let loop ((l1 vars)
942 (l2 vals)
943 (new-substs substs))
944 (if (null? l1)
945 new-substs
946 (let ((var (car l1))
947 (val (car l2)))
948 (cond ((or (cst? val)
949 (and (ref? val)
950 (or (bound? (ref-var val))
951 (global-singly-bound? val)))
952 (and (prc? val)
953 (ptset-every? oper-pos? (var-refs var))))
954 (loop (cdr l1)
955 (cdr l2)
956 (cons (cons var val) new-substs)))
957 (else
958 (loop (cdr l1)
959 (cdr l2)
960 new-substs)))))))
962 (define (br-app-inline ptree br-oper args substs reason expansion-limit)
964 ; invariant: (or (cst? br-oper) (ref? br-oper))
966 (and (ref? br-oper)
967 (let* ((var (ref-var br-oper))
968 (val (var-to-val var substs)))
970 (define (inline-procedure new-expansion-limit)
971 (let ((cloned-oper (clone-ptree val)))
972 (delete-ptree br-oper)
973 (br-app ptree cloned-oper args substs reason
974 new-expansion-limit)))
976 (and val
977 (prc? val)
978 (inline? (node-env val))
979 (if (and (bound? var)
980 (= (ptset-size (var-refs var)) 1)
981 (not (varset-member? var (bound-free-variables val))))
983 ; Procedure is referenced once and it is not direcly
984 ; recursive so inline it without changing the
985 ; expansion limit (the original code will be removed
986 ; by br-let).
988 (inline-procedure expansion-limit)
990 ; Procedure is referenced more than once or it is
991 ; directly recursive so we inline it only if we
992 ; don't exceed the expansion limit.
994 (let* ((size-val
995 (ptree-size val))
996 (size-ptree
997 (ptree-size ptree))
998 (new-limit
999 (- (if expansion-limit
1000 (car expansion-limit)
1001 (quotient (* (inlining-limit (node-env ptree))
1002 size-ptree)
1003 100))
1004 (- size-val 1))))
1005 (and (>= new-limit 0)
1006 (if expansion-limit
1007 (begin
1008 (set-car! expansion-limit new-limit)
1009 (inline-procedure expansion-limit))
1010 (inline-procedure (list new-limit))))))))))
1012 (define (br-app-simplify ptree br-oper args substs reason expansion-limit)
1014 ; invariant: (or (cst? br-oper) (ref? br-oper))
1016 (let* ((br-args
1017 (map (lambda (arg) (br arg substs 'need expansion-limit)) args))
1018 (proc
1019 (and (constant-fold? (node-env ptree))
1020 (specialize-app br-oper br-args (node-env ptree))))
1021 (simp
1022 (and proc
1023 (nb-args-conforms? (length args) (proc-obj-call-pat proc))
1024 (proc-obj-simplify proc)))
1025 (simplified-ptree
1026 (and simp
1027 (simp ptree br-args))))
1028 (if simplified-ptree
1029 (begin
1030 (delete-ptree br-oper)
1031 (for-each delete-ptree br-args)
1032 simplified-ptree)
1033 (new-call (node-source ptree) (node-env ptree)
1034 br-oper
1035 br-args))))
1037 (define (ptree-size ptree)
1038 (let loop ((lst (node-children ptree)) (n 1))
1039 (if (null? lst)
1040 n
1041 (loop (cdr lst) (+ n (ptree-size (car lst)))))))
1043 (define (side-effects-impossible? ptree)
1045 (cond ((cst? ptree)
1046 #t)
1048 ((ref? ptree)
1049 #t)
1051 ((set? ptree) ; variable guaranteed to be a global variable
1052 #f)
1054 ((tst? ptree)
1055 (and (side-effects-impossible? (tst-pre ptree))
1056 (side-effects-impossible? (tst-con ptree))
1057 (side-effects-impossible? (tst-alt ptree))))
1059 ((conj? ptree)
1060 (and (side-effects-impossible? (conj-pre ptree))
1061 (side-effects-impossible? (conj-alt ptree))))
1063 ((disj? ptree)
1064 (and (side-effects-impossible? (disj-pre ptree))
1065 (side-effects-impossible? (disj-alt ptree))))
1067 ((prc? ptree)
1068 #t)
1070 ((app? ptree)
1071 (let ((oper (app-oper ptree))
1072 (args (app-args ptree)))
1073 (and (every? side-effects-impossible? args)
1074 (if (and (prc? oper) ; applying a lambda-expr is like a 'let'
1075 (prc-req-and-opt-parms-only? oper)
1076 (= (length (prc-parms oper)) (length args)))
1077 (side-effects-impossible? (prc-body oper))
1078 (let ((proc (app->specialized-proc ptree)))
1079 (and proc
1080 (not (proc-obj-side-effects? proc))))))))
1082 ((fut? ptree)
1083 (side-effects-impossible? (fut-val ptree)))
1085 (else
1086 (compiler-internal-error "side-effects-impossible?, unknown parse tree node type"))))
1088 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1089 ;;
1090 ;; Lambda-lifting procedure:
1091 ;; ------------------------
1093 ;; (lambda-lift lst) takes a list of parse-trees and returns a list
1094 ;; where each parse-tree has been modified so that some of its
1095 ;; procedures (i.e. lambda-expressions) are replaced with weaker ones
1096 ;; (i.e. lambda-expressions having fewer or no closed variables). It
1097 ;; is assumed that 'ptree' has already been assignment-converted. The
1098 ;; only procedures that are lambda-lifted are named procedures and
1099 ;; procedures which are passed to some primitive higher-order functions
1100 ;; (such as call-with-current-continuation).
1102 (define (lambda-lift lst)
1103 (for-each (lambda (ptree)
1104 (ll! ptree (varset-empty) '()))
1105 lst)
1106 lst)
1108 (define (ll! ptree cst-procs env)
1110 (define (new-env env vars)
1111 (define (loop i l)
1112 (if (pair? l)
1113 (let ((var (car l)))
1114 (cons (cons var (cons (ptset-size (var-refs var)) i))
1115 (loop (+ i 1) (cdr l))))
1116 env))
1117 (loop (length env) vars))
1119 (cond ((or (cst? ptree)
1120 (ref? ptree)
1121 (set? ptree)
1122 (def? ptree) ; guaranteed to be a toplevel definition
1123 (tst? ptree)
1124 (conj? ptree)
1125 (disj? ptree)
1126 (fut? ptree))
1127 (for-each (lambda (child) (ll! child cst-procs env))
1128 (node-children ptree)))
1130 ((prc? ptree)
1131 (ll! (prc-body ptree) cst-procs (new-env env (prc-parms ptree))))
1133 ((app? ptree)
1134 (let ((oper (app-oper ptree))
1135 (args (app-args ptree)))
1136 (if (and (prc? oper) ; applying a lambda-expr is like a 'let'
1137 (prc-req-and-opt-parms-only? oper)
1138 (= (length (prc-parms oper)) (length args)))
1139 (ll!-let ptree cst-procs (new-env env (prc-parms oper)))
1140 (ll!-call ptree cst-procs env))))
1142 (else
1143 (compiler-internal-error "ll!, unknown parse tree node type"))))
1145 (define (ll!-call ptree cst-procs env)
1147 (for-each (lambda (child) (ll! child cst-procs env))
1148 (node-children ptree))
1150 (let* ((oper (app-oper ptree))
1151 (proc (cond ((cst? oper) (cst-val oper))
1152 ((ref? oper) (global-proc-obj oper))
1153 (else #f))))
1154 (if (proc-obj? proc)
1155 (let* ((lift-pat
1156 (proc-obj-lift-pat proc))
1157 (receiver-arg-pos
1158 (modulo (quotient lift-pat 1000) 10))
1159 (min-nb-args
1160 (modulo (quotient lift-pat 100) 10))
1161 (nb-req-and-opt-parms
1162 (modulo (quotient lift-pat 10) 10))
1163 (max-lifted-vars
1164 (modulo lift-pat 10))
1165 (args
1166 (app-args ptree))
1167 (nb-args
1168 (length args)))
1169 (if (and (< 0 receiver-arg-pos)
1170 (<= min-nb-args nb-args))
1171 (let ((receiver
1172 (list-ref args (- receiver-arg-pos 1))))
1173 (if (and (prc? receiver)
1174 (lambda-lift? (node-env receiver))
1175 (prc-req-and-opt-parms-only? receiver)
1176 (<= nb-req-and-opt-parms
1177 (length (prc-parms receiver)))
1178 (= (- (length (prc-parms receiver))
1179 nb-req-and-opt-parms)
1180 (- nb-args min-nb-args)))
1181 (let ((vars
1182 (ll-lifted-vars (bound-free-variables receiver)
1183 cst-procs
1184 env)))
1185 (if (and (not (null? vars))
1186 (<= (+ (length vars) (- nb-args min-nb-args))
1187 max-lifted-vars))
1188 (let ((cloned-vars (clone-vars vars)))
1190 ;; modify call site
1192 (define (new-ref* var)
1193 (new-ref (var-source var) (node-env ptree) var))
1195 (node-children-set!
1196 ptree
1197 (cons oper
1198 (append (take args min-nb-args)
1199 (map new-ref* vars)
1200 (drop args min-nb-args))))
1202 ;; modify receiver procedure
1204 (prc-parms-set!
1205 receiver
1206 (append (take (prc-parms receiver)
1207 nb-req-and-opt-parms)
1208 cloned-vars
1209 (drop (prc-parms receiver)
1210 nb-req-and-opt-parms)))
1211 (for-each (lambda (x) (var-bound-set! x receiver))
1212 cloned-vars)
1213 (node-fv-invalidate! receiver)
1214 (for-each (lambda (x y) (var-clone-set! x y))
1215 vars
1216 cloned-vars)
1217 (ll-rename! receiver)
1218 (for-each (lambda (x) (var-clone-set! x #f))
1219 vars)))))))))))
1221 (define (ll!-let ptree cst-procs env)
1222 (let* ((proc (app-oper ptree))
1223 (vals (app-args ptree))
1224 (vars (prc-parms proc))
1225 (var-val-map (pair-up vars vals)))
1227 (define (var->val var) (cdr (assq var var-val-map)))
1229 (define (liftable-proc-vars vars)
1230 (let loop ((cst-proc-vars-list
1231 (keep (lambda (var)
1232 (let ((val (var->val var)))
1233 (and (prc? val)
1234 (lambda-lift? (node-env val))
1235 (ptset-every? oper-pos? (var-refs var)))))
1236 vars)))
1237 (let* ((cst-proc-vars
1238 (list->varset cst-proc-vars-list))
1239 (non-cst-proc-vars-list
1240 (keep (lambda (var)
1241 (let ((val (var->val var)))
1242 (and (prc? val)
1243 (not (varset-member? var cst-proc-vars)))))
1244 vars))
1245 (non-cst-proc-vars
1246 (list->varset non-cst-proc-vars-list))
1247 (cst-proc-vars-list*
1248 (keep (lambda (var)
1249 (not (varset-intersects?
1250 (bound-free-variables (var->val var))
1251 non-cst-proc-vars)))
1252 cst-proc-vars-list)))
1253 (if (= (length cst-proc-vars-list)
1254 (length cst-proc-vars-list*))
1255 cst-proc-vars-list
1256 (loop cst-proc-vars-list*)))))
1258 (define (transitively-closed-bound-free-variables vars)
1259 (let ((tcbfv-map
1260 (map (lambda (var)
1261 (cons var (bound-free-variables (var->val var))))
1262 vars)))
1263 (let loop ()
1264 (let ((changed? #f))
1265 (for-each (lambda (var-tcbfv)
1266 (let ((tcbfv (cdr var-tcbfv)))
1267 (let loop2 ((l (varset->list tcbfv))
1268 (fv tcbfv))
1269 (if (null? l)
1270 (if (not (= (varset-size fv)
1271 (varset-size tcbfv)))
1272 (begin
1273 (set-cdr! var-tcbfv fv)
1274 (set! changed? #t)))
1275 (let ((x (assq (car l) tcbfv-map)))
1276 (loop2 (cdr l)
1277 (if x
1278 (varset-union fv (cdr x))
1279 fv)))))))
1280 tcbfv-map)
1281 (if changed?
1282 (loop)
1283 tcbfv-map)))))
1285 (let* ((tcbfv-map
1286 (transitively-closed-bound-free-variables
1287 (liftable-proc-vars vars)))
1288 (cst-proc-vars-list
1289 (map car tcbfv-map))
1290 (cst-procs*
1291 (varset-union (list->varset cst-proc-vars-list) cst-procs)))
1293 (define (var->tcbfv var) (cdr (assq var tcbfv-map)))
1295 (define (lifted-vars var)
1296 (ll-lifted-vars (var->tcbfv var) cst-procs* env))
1298 (define (lift-app! var)
1299 (let* ((val (var->val var))
1300 (vars (lifted-vars var)))
1301 (if (not (null? vars))
1302 (for-each (lambda (oper)
1303 (let ((node (node-parent oper)))
1305 (define (new-ref* var)
1306 (new-ref (var-source var) (node-env node) var))
1308 (node-children-set! node
1309 (cons (app-oper node)
1310 (append (map new-ref* vars)
1311 (app-args node))))))
1312 (ptset->list (var-refs var))))))
1314 (define (lift-prc! var)
1315 (let* ((val (var->val var))
1316 (vars (lifted-vars var)))
1317 (if (not (null? vars))
1318 (let ((cloned-vars (clone-vars vars)))
1319 (prc-parms-set! val (append cloned-vars (prc-parms val)))
1320 (for-each (lambda (x) (var-bound-set! x val)) cloned-vars)
1321 (node-fv-invalidate! val)
1322 (for-each (lambda (x y) (var-clone-set! x y)) vars cloned-vars)
1323 (ll-rename! val)
1324 (for-each (lambda (x) (var-clone-set! x #f)) vars)))))
1326 (for-each lift-app! cst-proc-vars-list)
1327 (for-each lift-prc! cst-proc-vars-list)
1328 (for-each (lambda (node) (ll! node cst-procs* env)) vals)
1329 (ll! (prc-body proc) cst-procs* env))))
1331 (define (ll-lifted-vars bfv cst-procs env)
1333 (define (order-vars vars)
1334 (map car
1335 (sort-list (map (lambda (var) (assq var env)) vars)
1336 (lambda (x y)
1337 ;;;; (if (= (cadr x) (cadr y))
1338 ;;;; (< (cddr x) (cddr y))
1339 ;;;; (< (cadr x) (cadr y)))
1340 (< (cddr x) (cddr y))))))
1342 (order-vars
1343 (varset->list (varset-difference bfv cst-procs))))
1345 (define (ll-rename! ptree)
1347 (if (ref? ptree)
1348 (let* ((var (ref-var ptree))
1349 (x (var-clone var)))
1350 (if x
1351 (begin
1352 (var-refs-set! var (ptset-remove (var-refs var) ptree))
1353 (var-refs-set! x (ptset-adjoin (var-refs x) ptree))
1354 (ref-var-set! ptree x)))))
1356 (node-fv-set! ptree #t)
1357 (node-bfv-set! ptree #t)
1359 (for-each (lambda (child) (ll-rename! child))
1360 (node-children ptree)))
1362 ;;;----------------------------------------------------------------------------
1363 ;;
1364 ;; Debugging stuff:
1366 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1367 ;;
1368 ;; (parse-tree->expression ptree) returns the Scheme expression corresponding to
1369 ;; the parse tree 'ptree'.
1371 (define (parse-tree->expression ptree)
1372 (se ptree '() (list 0)))
1374 (define (se ptree env num)
1376 (cond ((cst? ptree)
1377 (let ((val (cst-val ptree)))
1378 (se-constant val)))
1380 ((ref? ptree)
1381 (se-var->id (ref-var ptree) env))
1383 ((set? ptree)
1384 (list set!-sym
1385 (se-var->id (set-var ptree) env)
1386 (se (set-val ptree) env num)))
1388 ((def? ptree)
1389 (list define-sym
1390 (se-var->id (def-var ptree) env)
1391 (se (def-val ptree) env num)))
1393 ((tst? ptree)
1394 (list if-sym (se (tst-pre ptree) env num)
1395 (se (tst-con ptree) env num)
1396 (se (tst-alt ptree) env num)))
1398 ((conj? ptree)
1399 (list and-sym (se (conj-pre ptree) env num)
1400 (se (conj-alt ptree) env num)))
1402 ((disj? ptree)
1403 (list or-sym (se (disj-pre ptree) env num)
1404 (se (disj-alt ptree) env num)))
1406 ((prc? ptree)
1407 (let ((new-env (se-rename ptree env num)))
1408 (list lambda-sym
1409 (se-parameters (prc-parms ptree)
1410 (prc-opts ptree)
1411 (prc-keys ptree)
1412 (prc-rest? ptree)
1413 new-env
1414 num)
1415 (se (prc-body ptree) new-env num))))
1417 ((app? ptree)
1418 (let ((oper (app-oper ptree))
1419 (args (app-args ptree)))
1420 (if (and (prc? oper) ; applying a lambda-expr is like a 'let'
1421 (prc-req-and-opt-parms-only? oper)
1422 (= (length (prc-parms oper)) (length args)))
1423 (let ((new-env (se-rename oper env num)))
1424 (list
1425 (if (varset-intersects?
1426 (list->varset (prc-parms oper))
1427 (varset-union-multi (map bound-free-variables args)))
1428 letrec-sym
1429 let-sym)
1430 (se-bindings (prc-parms oper) args new-env num)
1431 (se (prc-body oper) new-env num)))
1432 (map (lambda (x) (se x env num)) (cons oper args)))))
1434 ((fut? ptree)
1435 (list future-sym (se (fut-val ptree) env num)))
1437 (else
1438 (compiler-internal-error "se, unknown parse tree node type"))))
1440 (define use-actual-primitives-in-expression? #t)
1442 (define (se-constant val)
1443 (if (self-evaluating? val)
1444 val
1445 (list quote-sym
1446 (if (proc-obj? val)
1447 (if use-actual-primitives-in-expression?
1448 (eval (string->symbol (proc-obj-name val)))
1449 (list '*primitive* (proc-obj-name val)))
1450 val))))
1452 (define (se-var->id var env)
1453 (let ((id (let ((x (assq var env)))
1454 (if x (cdr x) (var-name var)))))
1455 ;; for debugging:
1456 ;; (string->symbol
1457 ;; (string-append (symbol->string id)
1458 ;; ":"
1459 ;; (number->string (##object->serial-number var))))
1460 id))
1462 (define use-dotted-rest-parameter-when-possible? #t)
1464 (define (se-parameters parms opts keys rest? env num)
1466 (define (se-required parms n)
1467 (if (= n 0)
1468 (se-opts parms)
1469 (let ((parm (se-var->id (car parms) env)))
1470 (cons parm (se-required (cdr parms) (- n 1))))))
1472 (define (se-opts parms)
1473 (if (null? opts)
1474 (se-rest-and-keys parms)
1475 (cons optional-object
1476 (let loop ((parms parms) (opts opts))
1477 (if (null? opts)
1478 (se-rest-and-keys parms)
1479 (let ((parm (se-var->id (car parms) env)))
1480 (cons (list parm (se-constant (car opts)))
1481 (loop (cdr parms) (cdr opts)))))))))
1483 (define (se-rest-and-keys parms)
1485 (define (se-rest-at-end parm)
1486 (if use-dotted-rest-parameter-when-possible?
1487 parm
1488 (cons rest-object (cons parm '()))))
1490 (if rest?
1491 (let ((parm (se-var->id (car (last-pair parms)) env)))
1492 (if (not keys)
1493 (se-rest-at-end parm)
1494 (if (eq? rest? 'dsssl)
1495 (cons rest-object (cons parm (se-keys parms '())))
1496 (se-keys parms (se-rest-at-end parm)))))
1497 (se-keys parms '())))
1499 (define (se-keys parms tail)
1500 (if (not keys)
1501 tail
1502 (cons key-object
1503 (let loop ((parms parms) (keys keys))
1504 (if (null? keys)
1505 tail
1506 (let ((parm (se-var->id (car parms) env)))
1507 (cons (list parm (se-constant (cdr (car keys))))
1508 (loop (cdr parms) (cdr keys)))))))))
1510 (se-required parms
1511 (- (length parms)
1512 (length opts)
1513 (if keys (length keys) 0)
1514 (if rest? 1 0))))
1516 (define (se-bindings vars vals env num)
1517 (if (null? vars)
1518 '()
1519 (cons (list (se-var->id (car vars) env) (se (car vals) env num))
1520 (se-bindings (cdr vars) (cdr vals) env num))))
1522 (define (se-rename proc env num)
1523 (let* ((parms
1524 (prc-parms proc))
1525 (free-vars
1526 (varset->list (free-variables (prc-body proc))))
1527 (p-names
1528 (map var-name parms))
1529 (fv-names
1530 (map var-name free-vars))
1531 (names
1532 (append p-names fv-names))
1533 (n
1534 (length p-names)))
1536 (define (conflict? var i)
1537 (let* ((p (pos-in-list var free-vars))
1538 (k (if p (+ p n) i)))
1539 (let loop ((lst names) (j 0))
1540 (if (null? lst)
1541 #f
1542 (let ((x (car lst)))
1543 (if (and (not (= i j))
1544 (not (= k j))
1545 (eq? x (var-name var)))
1546 #t
1547 (loop (cdr lst) (+ j 1))))))))
1549 (define (rename vars i)
1550 (if (null? vars)
1551 env
1552 (let* ((var (car vars))
1553 (id (var-name var)))
1554 (cons (cons var
1555 (if (conflict? var i)
1556 (begin
1557 (set-car! num (+ (car num) 1))
1558 (string->symbol
1559 (string-append (symbol->string id)
1560 "#"
1561 (number->string (car num)))))
1562 id))
1563 (rename (cdr vars) (+ i 1))))))
1566 (rename parms 0)))
1568 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1570 ;; C-interface stuff:
1572 (define (c-interface-begin module-name)
1573 (set! c-interface-module-name module-name)
1574 (set! c-interface-proc-count 0)
1575 (set! c-interface-obj-count 0)
1576 (set! c-interface-types scheme-to-c-notation)
1577 (set! c-interface-release-fns '())
1578 (set! c-interface-release-fn-count 0)
1579 (set! c-interface-converters '())
1580 (set! c-interface-converter-count 0)
1581 (set! c-interface-decls '())
1582 (set! c-interface-procs '())
1583 (set! c-interface-inits '())
1584 (set! c-interface-objs '())
1585 #f)
1587 (define (c-interface-end)
1588 (let ((i (make-c-intf (reverse c-interface-decls)
1589 (reverse c-interface-procs)
1590 (reverse c-interface-inits)
1591 (reverse c-interface-objs))))
1592 (set! c-interface-module-name #f)
1593 (set! c-interface-proc-count #f)
1594 (set! c-interface-obj-count #f)
1595 (set! c-interface-types #f)
1596 (set! c-interface-release-fns #f)
1597 (set! c-interface-release-fn-count #f)
1598 (set! c-interface-converters #f)
1599 (set! c-interface-converter-count #f)
1600 (set! c-interface-decls #f)
1601 (set! c-interface-procs #f)
1602 (set! c-interface-inits #f)
1603 (set! c-interface-objs #f)
1604 i))
1606 (define c-interface-module-name #f)
1607 (define c-interface-proc-count #f)
1608 (define c-interface-obj-count #f)
1609 (define c-interface-types #f)
1610 (define c-interface-release-fns #f)
1611 (define c-interface-release-fn-count #f)
1612 (define c-interface-converters #f)
1613 (define c-interface-converter-count #f)
1614 (define c-interface-decls #f)
1615 (define c-interface-procs #f)
1616 (define c-interface-inits #f)
1617 (define c-interface-objs #f)
1619 (define (add-c-type name type)
1620 (set! c-interface-types
1621 (cons (cons name type) c-interface-types))
1622 #f)
1624 (define (add-c-decl declaration-string)
1625 (set! c-interface-decls
1626 (cons declaration-string c-interface-decls))
1627 #f)
1629 (define (add-c-proc c-proc)
1630 (set! c-interface-proc-count (+ c-interface-proc-count 1))
1631 (set! c-interface-procs
1632 (cons c-proc c-interface-procs))
1633 #f)
1635 (define (add-c-init initialization-code-string)
1636 (set! c-interface-inits
1637 (cons initialization-code-string c-interface-inits))
1638 #f)
1640 (define (add-c-obj obj)
1641 (set! c-interface-obj-count (+ c-interface-obj-count 1))
1642 (set! c-interface-objs
1643 (cons obj c-interface-objs))
1644 #f)
1646 (define (make-c-intf decls procs inits objs) (vector decls procs inits objs))
1647 (define (c-intf-decls c-intf) (vector-ref c-intf 0))
1648 (define (c-intf-decls-set! c-intf x) (vector-set! c-intf 0 x))
1649 (define (c-intf-procs c-intf) (vector-ref c-intf 1))
1650 (define (c-intf-procs-set! c-intf x) (vector-set! c-intf 1 x))
1651 (define (c-intf-inits c-intf) (vector-ref c-intf 2))
1652 (define (c-intf-inits-set! c-intf x) (vector-set! c-intf 2 x))
1653 (define (c-intf-objs c-intf) (vector-ref c-intf 3))
1654 (define (c-intf-objs-set! c-intf x) (vector-set! c-intf 3 x))
1656 (define (make-c-proc scheme-name c-name arity body)
1657 (vector c-proc-tag scheme-name c-name arity body))
1659 (define c-proc-tag (list 'c-proc))
1661 (define (c-proc? x)
1662 (and (vector? x)
1663 (> (vector-length x) 0)
1664 (eq? (vector-ref x 0) c-proc-tag)))
1666 (define (c-proc-scheme-name x) (vector-ref x 1))
1667 (define (c-proc-c-name x) (vector-ref x 2))
1668 (define (c-proc-arity x) (vector-ref x 3))
1669 (define (c-proc-body x) (vector-ref x 4))
1671 (define (**c-define-type-expr? source)
1672 (and (match **c-define-type-sym -3 source)
1673 (or (let ((len (length (source-code source))))
1674 (and (or (= len 3) (= len 6))
1675 (proper-c-type-definition? source)))
1676 (ill-formed-special-form source))))
1678 (define (proper-c-type-definition? source)
1679 (let* ((code (source-code source))
1680 (name-source (cadr code))
1681 (name (source-code name-source)))
1682 (cond ((not (symbol-object? name))
1683 (pt-syntax-error
1684 name-source
1685 "C type's name must be an identifier"))
1686 ((assq name c-interface-types)
1687 (pt-syntax-error
1688 name-source
1689 "C type's name is already defined"))
1690 ((= (length code) 3)
1691 (let ((type-source (caddr code)))
1692 (check-c-type type-source #f #t))) ; allow all types
1693 (else
1694 (let* ((ctype-source (caddr code))
1695 (ctype (source-code ctype-source))
1696 (ctos-source (cadddr code))
1697 (ctos (source-code ctos-source))
1698 (stoc-source (cadddr (cdr code)))
1699 (stoc (source-code stoc-source))
1700 (cleanup-source (cadddr (cddr code)))
1701 (cleanup (source-code cleanup-source)))
1702 (cond ((not (string? ctype))
1703 (pt-syntax-error
1704 ctype-source
1705 "Second argument to 'c-define-type' must be a string"))
1706 ((not (string? ctos))
1707 (pt-syntax-error
1708 ctos-source
1709 "Third argument to 'c-define-type' must be a string"))
1710 ((not (valid-c-or-c++-function-id? ctos))
1711 (pt-syntax-error
1712 ctos-source
1713 "Ill-formed C function identifier"))
1714 ((not (string? stoc))
1715 (pt-syntax-error
1716 stoc-source
1717 "Fourth argument to 'c-define-type' must be a string"))
1718 ((not (valid-c-or-c++-function-id? stoc))
1719 (pt-syntax-error
1720 stoc-source
1721 "Ill-formed C function identifier"))
1722 ((not (or (false-object? cleanup)
1723 (eq? cleanup #t)))
1724 (pt-syntax-error
1725 stoc-source
1726 "Fifth argument to 'c-define-type' must be a boolean"))
1727 (else
1728 #t)))))))
1730 (define (c-type-definition-name source)
1731 (let ((code (source-code source)))
1732 (cadr code)))
1734 (define (c-type-definition-type source)
1735 (let ((code (source-code source)))
1736 (if (= (length code) 3)
1737 (vector 'alias
1738 (caddr code))
1739 (vector 'c-type
1740 (source-code (caddr code))
1741 (source-code (cadddr code))
1742 (source-code (cadddr (cdr code)))
1743 (source-code (cadddr (cddr code)))))))
1745 (define (**c-declare-expr? source)
1746 (and (match **c-declare-sym 2 source)
1747 (let ((code (source-code source)))
1748 (or (string? (source-code (cadr code)))
1749 (pt-syntax-error
1750 source
1751 "Argument to 'c-declare' must be a string")))))
1753 (define (c-declaration-body source)
1754 (cadr (source-code source)))
1756 (define (**c-initialize-expr? source)
1757 (and (match **c-initialize-sym 2 source)
1758 (let ((code (source-code source)))
1759 (or (string? (source-code (cadr code)))
1760 (pt-syntax-error
1761 source
1762 "Argument to 'c-initialize' must be a string")))))
1764 (define (c-initialization-body source)
1765 (cadr (source-code source)))
1767 (define (**c-lambda-expr? source)
1768 (and (match **c-lambda-sym 4 source)
1769 (let ((code (source-code source)))
1770 (if (not (string? (source-code (cadddr code))))
1771 (pt-syntax-error
1772 source
1773 "Third argument to 'c-lambda' must be a string")
1774 (check-c-function-type (cadr code) (caddr code) #f)))))
1776 (define (**c-define-expr? source env)
1777 (and (match **c-define-sym -7 source)
1778 (proper-c-definition? source env)))
1780 (define (proper-c-definition? source env)
1781 (let* ((code (source-code source))
1782 (pattern-source (cadr code))
1783 (pattern (source-code pattern-source))
1784 (arg-typs-source (caddr code))
1785 (res-typ-source (cadddr code))
1786 (name-source (car (cddddr code)))
1787 (name (source-code name-source))
1788 (scope-source (cadr (cddddr code)))
1789 (scope (source-code scope-source)))
1790 (cond ((not (pair? pattern))
1791 (pt-syntax-error
1792 pattern-source
1793 "Ill-formed definition pattern"))
1794 ((not (bindable-var? (car pattern) env))
1795 (pt-syntax-error
1796 (car pattern)
1797 "Procedure name must be an identifier"))
1798 (else
1799 (and (check-c-function-type arg-typs-source res-typ-source #f)
1800 (cond ((not (string? name))
1801 (pt-syntax-error
1802 name-source
1803 "Fourth argument to 'c-define' must be a string"))
1804 ((not (valid-c-or-c++-function-id? name))
1805 (pt-syntax-error
1806 name-source
1807 "Ill-formed C function identifier"))
1808 ((not (string? scope))
1809 (pt-syntax-error
1810 scope-source
1811 "Fifth argument to 'c-define' must be a string"))
1812 (else
1813 #t)))))))
1815 (define (c-definition-name source)
1816 (let ((code (source-code source)))
1817 (car (source-code (cadr code)))))
1819 (define (c-definition-value source)
1820 (let ((code (source-code source))
1821 (loc (source-locat source)))
1822 (make-source
1823 (cons (make-source **lambda-sym loc)
1824 (cons (parms->source (cdr (source-code (cadr code))) loc)
1825 (cdr (cddddr code))))
1826 loc)))
1828 (define (c-definition-param-types source)
1829 (source-code (caddr (source-code source))))
1831 (define (c-definition-result-type source)
1832 (cadddr (source-code source)))
1834 (define (c-definition-proc-name source)
1835 (car (cddddr (source-code source))))
1837 (define (c-definition-scope source)
1838 (cadr (cddddr (source-code source))))
1840 (define (c-type-pt-syntax-error source err-source msg . args)
1841 (apply pt-syntax-error (cons (or err-source source) (cons msg args))))
1843 (define (check-c-function-type arg-typs-source res-typ-source err-source)
1844 (and (check-c-arg-types arg-typs-source err-source)
1845 (check-c-result-type res-typ-source err-source)))
1847 (define (check-c-arg-types arg-typs-source err-source)
1848 (let ((arg-typs (source-code arg-typs-source)))
1849 (if (not (proper-length arg-typs))
1850 (c-type-pt-syntax-error
1851 arg-typs-source
1852 err-source
1853 "Ill-terminated C function argument type list")
1854 (let loop ((lst arg-typs))
1855 (if (pair? lst)
1856 (and (check-c-type (car lst) err-source #f) ; void not allowed
1857 (loop (cdr lst)))
1858 #t)))))
1860 (define (check-c-result-type res-typ-source err-source)
1861 (check-c-type res-typ-source err-source #t)) ; allow all types
1863 (define (check-c-type typ-source err-source void-allowed?)
1865 (define (ill-formed-c-type)
1866 (c-type-pt-syntax-error typ-source err-source "Ill-formed C type"))
1868 (let ((typ (source-code typ-source)))
1869 (cond ((pair? typ)
1870 (let ((len (proper-length (cdr typ))))
1871 (if len
1872 (let ((head (source-code (car typ))))
1874 (define (check pointer? err-msg)
1875 (or (and (>= len 1)
1876 (<= len 3)
1877 (let* ((x-source (cadr typ))
1878 (x (source-code x-source)))
1879 (if pointer?
1880 (check-c-type
1881 x-source
1882 err-source
1883 #t) ; allow all types
1884 (and (string? x)
1885 (valid-c-or-c++-type-id? x))))
1886 (or (< len 2)
1887 (let ((tag (source-code (caddr typ))))
1888 (or (false-object? tag)
1889 (symbol-object? tag)
1890 (and (pair? tag)
1891 (proper-length tag)
1892 (every?
1893 (lambda (x)
1894 (symbol-object?
1895 (source-code x)))
1896 tag)))))
1897 (or (< len 3)
1898 (let ((id (source-code (cadddr typ))))
1899 (or (false-object? id)
1900 (and (string? id)
1901 (valid-c-or-c++-function-id? id))))))
1902 (c-type-pt-syntax-error
1903 typ-source
1904 err-source
1905 err-msg)))
1907 (define (check-function err-msg)
1908 (if (= len 2)
1909 (check-c-function-type
1910 (cadr typ)
1911 (caddr typ)
1912 err-source)
1913 (c-type-pt-syntax-error
1914 typ-source
1915 err-source
1916 err-msg)))
1918 (cond ((eq? head struct-sym)
1919 (check #f "Ill-formed C STRUCT type"))
1920 ((eq? head union-sym)
1921 (check #f "Ill-formed C UNION type"))
1922 ((eq? head type-sym)
1923 (check #f "Ill-formed C TYPE type"))
1924 ((eq? head pointer-sym)
1925 (check #t "Ill-formed C POINTER type"))
1926 ((eq? head nonnull-pointer-sym)
1927 (check #t "Ill-formed C NONNULL POINTER type"))
1928 ((eq? head function-sym)
1929 (check-function "Ill-formed C FUNCTION type"))
1930 ((eq? head nonnull-function-sym)
1931 (check-function "Ill-formed C NONNULL FUNCTION type"))
1932 (else
1933 (ill-formed-c-type))))
1935 (c-type-pt-syntax-error
1936 typ-source
1937 err-source
1938 "Ill-terminated C type"))))
1939 ((string? typ)
1940 (or (valid-c-or-c++-type-id? typ)
1941 (c-type-pt-syntax-error
1942 typ-source
1943 err-source
1944 "Ill-formed C type identifier")))
1945 ((symbol-object? typ)
1946 (if (eq? typ void-sym)
1947 (or void-allowed?
1948 (c-type-pt-syntax-error
1949 typ-source
1950 err-source
1951 "Ill-placed C VOID type"))
1952 (let ((x (assq typ c-interface-types)))
1953 (if x
1954 (let ((def (cdr x)))
1955 (case (vector-ref def 0)
1956 ((c-type)
1957 #t)
1958 (else
1959 (check-c-type
1960 (vector-ref def 1)
1961 typ-source
1962 void-allowed?))))
1963 (c-type-pt-syntax-error
1964 typ-source
1965 err-source
1966 "Undefined C type identifier:"
1967 typ)))))
1968 (else
1969 (ill-formed-c-type)))))
1971 (define (resolve-type typ-source)
1972 (let ((typ (source-code typ-source)))
1973 (if (symbol-object? typ)
1974 (let ((x (assq typ c-interface-types)))
1975 (if x
1976 (let ((def (cdr x)))
1977 (if (eq? (vector-ref def 0) 'alias)
1978 (resolve-type (vector-ref def 1))
1979 typ-source))
1980 typ-source))
1981 typ-source)))
1983 (define (void-type? typ-source)
1984 (eq? (source-code (resolve-type typ-source)) void-sym))
1986 (define (scmobj-type? typ-source)
1987 (eq? (source-code (resolve-type typ-source)) scheme-object-sym))
1989 (define (type-needs-cleanup? typ-source)
1990 (let ((typ (source-code typ-source)))
1991 (cond ((pair? typ)
1992 (let ((head (source-code (car typ))))
1993 (or (eq? head struct-sym)
1994 (eq? head union-sym)
1995 (eq? head type-sym)
1996 (eq? head function-sym)
1997 (eq? head nonnull-function-sym))))
1998 ((string? typ)
1999 #t)
2000 ((symbol-object? typ)
2001 (let ((x (assq typ c-interface-types)))
2002 (if x
2003 (let ((def (cdr x)))
2004 (case (vector-ref def 0)
2005 ((c-type)
2006 (vector-ref def 4))
2007 (else
2008 (type-needs-cleanup? (vector-ref def 1)))))
2009 #f)))
2010 (else
2011 #f))))
2013 (define (type-accessed-indirectly? typ-source)
2014 (let ((typ (source-code typ-source)))
2015 (cond ((pair? typ)
2016 (let ((head (source-code (car typ))))
2017 (cond ((eq? head struct-sym)
2018 (vector "STRUCT" (source-code (cadr typ))))
2019 ((eq? head union-sym)
2020 (vector "UNION" (source-code (cadr typ))))
2021 ((eq? head type-sym)
2022 (vector "TYPE" (source-code (cadr typ))))
2023 ((eq? head pointer-sym)
2024 '#("POINTER" #f))
2025 ((eq? head nonnull-pointer-sym)
2026 '#("NONNULLPOINTER" #f))
2027 ((eq? head function-sym)
2028 '#("FUNCTION" #f))
2029 ((eq? head nonnull-function-sym)
2030 '#("NONNULLFUNCTION" #f))
2031 (else
2032 #f))))
2033 ((string? typ)
2034 (vector "TYPE" typ))
2035 ((symbol-object? typ)
2036 (let ((x (assq typ c-interface-types)))
2037 (if x
2038 (let ((def (cdr x)))
2039 (case (vector-ref def 0)
2040 ((c-type)
2041 #f)
2042 (else
2043 (type-accessed-indirectly? (vector-ref def 1)))))
2044 #f)))
2045 (else
2046 #f))))
2048 (define (pt-c-lambda source env use)
2049 (let ((name
2050 (build-c-lambda
2051 (c-lambda-param-types source)
2052 (c-lambda-result-type source)
2053 (source-code (c-lambda-proc-name source)))))
2054 (new-ref source
2055 env
2056 (env-lookup-global-var env (string->symbol name)))))
2058 (define (c-lambda-param-types source)
2059 (source-code (cadr (source-code source))))
2061 (define (c-lambda-result-type source)
2062 (caddr (source-code source)))
2064 (define (c-lambda-proc-name source)
2065 (cadddr (source-code source)))
2067 (define (number-from-1 lst)
2068 (let loop ((i 1) (lst1 lst) (lst2 '()))
2069 (if (pair? lst1)
2070 (loop (+ i 1) (cdr lst1) (cons (cons (car lst1) i) lst2))
2071 (reverse lst2))))
2073 (define (c-type-converter to-scmobj? typ from to)
2075 (define (err)
2076 (compiler-internal-error "c-type-converter, unknown C type"))
2078 (define (convert kind name tag id)
2079 (let ((tag-str
2080 (if (false-object? tag)
2081 (string-append c-id-prefix "FAL")
2082 (let* ((tag-list (if (symbol-object? tag) (list tag) tag))
2083 (x (object-pos-in-list tag-list c-interface-objs)))
2084 (string-append
2085 c-id-prefix
2086 "C_OBJ_"
2087 (number->string
2088 (if x
2089 (- (- c-interface-obj-count x) 1)
2090 (let ((n c-interface-obj-count))
2091 (add-c-obj tag-list)
2092 n))))))))
2093 (if to-scmobj?
2095 (string-append
2096 (cond ((eq? kind pointer-sym)
2097 "POINTER_TO_SCMOBJ(")
2098 ((eq? kind nonnull-pointer-sym)
2099 "NONNULLPOINTER_TO_SCMOBJ(")
2100 (else
2101 (string-append
2102 (cond ((eq? kind struct-sym)
2103 "STRUCT_TO_SCMOBJ(")
2104 ((eq? kind union-sym)
2105 "UNION_TO_SCMOBJ(")
2106 (else
2107 "TYPE_TO_SCMOBJ("))
2108 name
2109 ",")))
2110 from "_voidstar," tag-str ","
2111 (if (false-object? id)
2112 (if (or (eq? kind pointer-sym)
2113 (eq? kind nonnull-pointer-sym))
2114 (string-append
2115 c-id-prefix
2116 "RELEASE_POINTER")
2117 (let* ((descr
2118 (cons kind name))
2119 (x
2120 (assoc descr c-interface-release-fns)))
2121 (if x
2122 (cdr x)
2123 (let* ((i
2124 c-interface-release-fn-count)
2125 (release-fn
2126 (string-append
2127 c-id-prefix
2128 "release_fn"
2129 (number->string i))))
2130 (set! c-interface-release-fn-count
2131 (+ i 1))
2132 (set! c-interface-release-fns
2133 (cons (cons descr release-fn)
2134 c-interface-release-fns))
2135 (add-c-decl
2136 (string-append
2137 c-id-prefix
2138 (cond ((eq? kind struct-sym)
2139 "DEF_RELEASE_FN_STRUCT(")
2140 ((eq? kind union-sym)
2141 "DEF_RELEASE_FN_UNION(")
2142 (else
2143 "DEF_RELEASE_FN_TYPE("))
2144 name
2145 ","
2146 release-fn
2147 ")"))
2148 release-fn))))
2149 id)
2150 "," to)
2152 (string-append
2153 (cond ((eq? kind pointer-sym)
2154 "SCMOBJ_TO_POINTER(")
2155 ((eq? kind nonnull-pointer-sym)
2156 "SCMOBJ_TO_NONNULLPOINTER(")
2157 (else
2158 (string-append
2159 (cond ((eq? kind struct-sym)
2160 "SCMOBJ_TO_STRUCT(")
2161 ((eq? kind union-sym)
2162 "SCMOBJ_TO_UNION(")
2163 (else
2164 "SCMOBJ_TO_TYPE("))
2165 name
2166 ",")))
2167 from "," to "_voidstar," tag-str))))
2169 (let ((t (source-code typ)))
2170 (cond ((pair? t)
2171 (let ((head (source-code (car t)))
2172 (len (length (cdr t))))
2173 (cond ((or (eq? head struct-sym)
2174 (eq? head union-sym)
2175 (eq? head type-sym)
2176 (eq? head pointer-sym)
2177 (eq? head nonnull-pointer-sym))
2178 (convert
2179 head
2180 (source-code (cadr t))
2181 (if (>= len 2)
2182 (source->expression (caddr t))
2183 (string->symbol (c-type-decl typ "")))
2184 (if (>= len 3)
2185 (source-code (cadddr t))
2186 false-object)))
2187 ((or (eq? head function-sym)
2188 (eq? head nonnull-function-sym))
2189 (if to-scmobj?
2190 (string-append
2191 (if (eq? head function-sym)
2192 "FUNCTION_TO_SCMOBJ("
2193 "NONNULLFUNCTION_TO_SCMOBJ(")
2194 from "_voidstar," to)
2195 (let ((converter
2196 (fn-param-converter typ)))
2197 (string-append
2198 (if (eq? head function-sym)
2199 "SCMOBJ_TO_FUNCTION("
2200 "SCMOBJ_TO_NONNULLFUNCTION(")
2201 from "," converter "," to "_voidstar"))))
2202 (else
2203 (err)))))
2204 ((string? t)
2205 (convert
2206 type-sym
2207 t
2208 false-object
2209 false-object))
2210 ((symbol-object? t)
2211 (let ((x (assq t c-interface-types)))
2212 (if x
2213 (let ((def (cdr x)))
2214 (case (vector-ref def 0)
2215 ((c-type)
2216 (if to-scmobj?
2217 (string-append
2218 (vector-ref def 2)
2219 "(" from "," to)
2220 (string-append
2221 (vector-ref def 3)
2222 "(" from "," to)))
2223 (else
2224 (c-type-converter
2225 to-scmobj?
2226 (vector-ref def 1)
2227 from
2228 to))))
2229 (err))))
2230 (else
2231 (err)))))
2233 (define nl-str (string #\newline))
2235 (define (c-preproc-define id val body)
2236 (string-append
2237 "#define " id " " val nl-str
2238 body
2239 "#undef " id nl-str))
2241 (define (c-preproc-define-default-empty id body)
2242 (string-append
2243 "#undef " id nl-str
2244 body
2245 "#ifndef " id nl-str
2246 "#define " id nl-str
2247 "#endif" nl-str))
2249 (define (c-result sfun? scheme-side?)
2250 (string-append
2251 c-id-prefix
2252 (if scheme-side?
2253 (if sfun? "SFUN_RESULT" "CFUN_RESULT")
2254 "result")))
2256 (define (c-argument scheme-side? numbered-typ)
2257 (let ((i (number->string (cdr numbered-typ))))
2258 (string-append
2259 c-id-prefix
2260 (if scheme-side? "ARG" "arg")
2261 i)))
2263 (define (c-declare-argument sfun? numbered-typ body)
2264 (let* ((c-id (c-argument #f numbered-typ))
2265 (scm-id (c-argument #t numbered-typ))
2266 (typ (car numbered-typ))
2267 (i (number->string (cdr numbered-typ)))
2268 (scmobj? (scmobj-type? typ))
2269 (indirect-access (type-accessed-indirectly? typ)))
2270 (string-append
2271 c-id-prefix
2272 (if scmobj?
2273 (if sfun? "BEGIN_SFUN_ARG_SCMOBJ(" "BEGIN_CFUN_ARG_SCMOBJ(")
2274 (if sfun? "BEGIN_SFUN_ARG(" "BEGIN_CFUN_ARG("))
2275 i
2276 (if scmobj?
2277 ""
2278 (string-append
2279 ","
2280 (if sfun?
2281 scm-id
2282 (if indirect-access
2283 (string-append "void* " c-id "_voidstar")
2284 (c-type-decl typ c-id)))))
2285 ")" nl-str
2286 (if indirect-access
2287 (if sfun?
2288 (if (vector-ref indirect-access 1)
2289 (let ((tail
2290 (string-append
2291 (vector-ref indirect-access 0)
2292 "("
2293 (vector-ref indirect-access 1)
2294 ","
2295 c-id "_voidstar,"
2296 c-id
2297 ")" nl-str)))
2298 (string-append
2299 c-id-prefix "BEGIN_SFUN_COPY_" tail
2300 body
2301 c-id-prefix "END_SFUN_COPY_" tail))
2302 (c-preproc-define
2303 (string-append c-id "_voidstar")
2304 (string-append c-id-prefix "SFUN_CAST(void*," c-id ")")
2305 body))
2306 (c-preproc-define
2307 c-id
2308 (string-append
2309 c-id-prefix
2310 (if (vector-ref indirect-access 1)
2311 (string-append
2312 "CFUN_CAST_AND_DEREF("
2313 (c-type-decl typ "*"))
2314 (string-append
2315 "CFUN_CAST("
2316 (c-type-decl typ "")))
2317 ","
2318 c-id "_voidstar)")
2319 body))
2320 body)
2321 c-id-prefix
2322 (if scmobj?
2323 (if sfun? "END_SFUN_ARG_SCMOBJ(" "END_CFUN_ARG_SCMOBJ(")
2324 (if sfun? "END_SFUN_ARG(" "END_CFUN_ARG("))
2325 i ")" nl-str)))
2327 (define (c-convert-representation sfun? to-scmobj? typ from to i body)
2328 (let ((tail
2329 (string-append
2330 (c-type-converter to-scmobj? typ from to)
2331 (if i (string-append "," i) "")
2332 ")" nl-str)))
2333 (string-append
2334 c-id-prefix (if sfun? "BEGIN_SFUN_" "BEGIN_CFUN_") tail
2335 body
2336 c-id-prefix (if sfun? "END_SFUN_" "END_CFUN_") tail)))
2338 (define (c-convert-argument sfun? numbered-typ body)
2339 (let* ((typ
2340 (car numbered-typ))
2341 (from
2342 (c-argument (not sfun?) numbered-typ))
2343 (to
2344 (c-argument sfun? numbered-typ))
2345 (i
2346 (number->string (cdr numbered-typ)))
2347 (decl
2348 (c-declare-argument
2349 sfun?
2350 numbered-typ
2351 (if (scmobj-type? typ)
2352 (c-preproc-define to from body)
2353 (c-convert-representation sfun? sfun? typ from to i body)))))
2354 (if sfun?
2355 decl
2356 (c-preproc-define
2357 from
2358 (string-append
2359 c-id-prefix
2360 "CFUN_ARG("
2361 i
2362 ")")
2363 decl))))
2365 (define (c-set-result sfun? result-typ)
2366 (cond ((void-type? result-typ)
2367 (string-append
2368 c-id-prefix
2369 (if sfun? "SFUN_SET_RESULT_VOID" "CFUN_SET_RESULT_VOID")
2370 nl-str))
2371 ((scmobj-type? result-typ)
2372 (string-append
2373 c-id-prefix
2374 (if sfun? "SFUN_SET_RESULT_SCMOBJ" "CFUN_SET_RESULT_SCMOBJ")
2375 nl-str))
2376 (else
2377 (c-convert-representation
2378 sfun?
2379 (not sfun?)
2380 result-typ
2381 (c-result sfun? sfun?)
2382 (c-result sfun? (not sfun?))
2383 #f
2384 (string-append
2385 c-id-prefix
2386 (if sfun? "SFUN_SET_RESULT" "CFUN_SET_RESULT")
2387 nl-str)))))
2389 (define (c-make-function sfun? param-typs result-typ make-body)
2390 (let ((cleanup?
2391 (not (every? (lambda (t) (not (type-needs-cleanup? t)))
2392 param-typs))))
2394 (define (convert-param-list)
2396 (define (scmobj-typ? numbered-typ)
2397 (scmobj-type? (car numbered-typ)))
2399 (define (not-scmobj-typ? numbered-typ)
2400 (not (scmobj-typ? numbered-typ)))
2402 (let ((numbered-param-typs (number-from-1 param-typs)))
2403 (let convert ((numbered-typs
2404 (append (keep scmobj-typ? numbered-param-typs)
2405 (keep not-scmobj-typ? numbered-param-typs))))
2406 (if (null? numbered-typs)
2407 (make-body (c-set-result sfun? result-typ) cleanup?)
2408 (c-convert-argument
2409 sfun?
2410 (car numbered-typs)
2411 (convert (cdr numbered-typs)))))))
2413 (c-preproc-define
2415 (string-append c-id-prefix "NARGS")
2417 (number->string (length param-typs))
2419 (if (void-type? result-typ)
2421 (string-append
2422 c-id-prefix
2423 (if sfun?
2424 (string-append
2425 "BEGIN_SFUN_VOID("
2426 sfun?
2427 ")")
2428 "BEGIN_CFUN_VOID")
2429 nl-str
2430 (convert-param-list)
2431 c-id-prefix
2432 (if sfun?
2433 "SFUN_ERROR_VOID"
2434 (if cleanup? "CFUN_ERROR_CLEANUP_VOID" "CFUN_ERROR_VOID"))
2435 nl-str
2436 (if sfun?
2437 (c-set-result sfun? result-typ)
2438 "")
2439 c-id-prefix
2440 (if sfun? "END_SFUN_VOID" "END_CFUN_VOID") nl-str)
2442 (let* ((c-id
2443 (c-result sfun? #f))
2444 (scmobj-result?
2445 (scmobj-type? result-typ))
2446 (indirect-access-result
2447 (type-accessed-indirectly? result-typ))
2448 (body
2449 (string-append
2450 c-id-prefix
2451 (if scmobj-result?
2452 (if sfun?
2453 (string-append
2454 "BEGIN_SFUN_SCMOBJ("
2455 sfun?
2456 ")")
2457 "BEGIN_CFUN_SCMOBJ")
2458 (string-append
2459 (if sfun?
2460 (string-append
2461 "BEGIN_SFUN("
2462 sfun?
2463 ",")
2464 "BEGIN_CFUN(")
2465 (if indirect-access-result
2466 (string-append "void* " c-id "_voidstar"
2467 (if sfun? " = 0" ""))
2468 (c-type-decl result-typ c-id))
2469 ")"))
2470 nl-str
2471 (convert-param-list)
2472 c-id-prefix
2473 (if scmobj-result?
2474 (if sfun?
2475 "SFUN_ERROR_SCMOBJ"
2476 (if cleanup? "CFUN_ERROR_CLEANUP_SCMOBJ" "CFUN_ERROR_SCMOBJ"))
2477 (if sfun?
2478 "SFUN_ERROR"
2479 (if cleanup? "CFUN_ERROR_CLEANUP" "CFUN_ERROR")))
2480 nl-str
2481 (if sfun?
2482 (c-set-result sfun? result-typ)
2483 "")
2484 c-id-prefix
2485 (if scmobj-result?
2486 (if sfun? "END_SFUN_SCMOBJ" "END_CFUN_SCMOBJ")
2487 (if sfun? "END_SFUN" "END_CFUN"))
2488 nl-str
2489 (if sfun?
2490 (string-append "return " c-id ";" nl-str)
2491 ""))))
2492 (if indirect-access-result
2494 (c-preproc-define
2495 c-id
2496 (string-append
2497 c-id-prefix
2498 (if sfun? "SFUN_CAST_AND_DEREF(" "CFUN_CAST_AND_DEREF(")
2499 (c-type-decl result-typ "*")
2500 ","
2501 (if (vector-ref indirect-access-result 1)
2502 ""
2503 "&")
2504 c-id "_voidstar)")
2505 body)
2507 body))))))
2509 (define (comma-separated strs)
2510 (if (null? strs)
2511 ""
2512 (string-append
2513 (car strs)
2514 (apply string-append
2515 (map (lambda (s) (string-append "," s)) (cdr strs))))))
2517 (define (c-type-decl typ inner)
2519 (define (err)
2520 (compiler-internal-error "c-type-decl, unknown C type"))
2522 (define (prefix-inner str)
2523 (if (and (> (string-length inner) 0)
2524 (c-id-subsequent? (string-ref inner 0)))
2525 (string-append str " " inner)
2526 (string-append str inner)))
2528 (let ((t (source-code typ)))
2529 (cond ((pair? t)
2530 (let ((head (source-code (car t))))
2531 (cond ((eq? head struct-sym)
2532 (prefix-inner
2533 (string-append "struct " (source-code (cadr t)))))
2534 ((eq? head union-sym)
2535 (prefix-inner
2536 (string-append "union " (source-code (cadr t)))))
2537 ((eq? head type-sym)
2538 (prefix-inner
2539 (source-code (cadr t))))
2540 ((or (eq? head pointer-sym)
2541 (eq? head nonnull-pointer-sym))
2542 (c-type-decl (cadr t)
2543 (string-append "*" inner)))
2544 ((or (eq? head function-sym)
2545 (eq? head nonnull-function-sym))
2546 (c-type-decl (caddr t)
2547 (string-append
2548 "(*" inner ") "
2549 (c-param-list-with-types
2550 (source-code (cadr t))))))
2551 (else
2552 (err)))))
2553 ((string? t)
2554 (prefix-inner t))
2555 ((symbol-object? t)
2556 (let ((x (assq t c-interface-types)))
2557 (if x
2558 (let ((def (cdr x)))
2559 (case (vector-ref def 0)
2560 ((c-type)
2561 (prefix-inner (vector-ref def 1)))
2562 (else
2563 (c-type-decl (vector-ref def 1) inner))))
2564 (err))))
2565 (else
2566 (err)))))
2568 (define (c-param-list-with-types typs)
2569 (if (null? typs)
2570 (string-append c-id-prefix "PVOID")
2571 (string-append
2572 c-id-prefix
2573 "P(("
2574 (comma-separated (map (lambda (typ) (c-type-decl typ "")) typs))
2575 "),())")))
2577 (define (c-param-id numbered-typ)
2578 (c-argument #f numbered-typ))
2580 (define (c-param-list-with-ids numbered-typs)
2581 (if (null? numbered-typs)
2582 (string-append c-id-prefix "PVOID")
2583 (string-append
2584 c-id-prefix
2585 "P(("
2586 (comma-separated
2587 (map (lambda (t) (c-type-decl (car t) (c-param-id t)))
2588 numbered-typs))
2589 "),("
2590 (comma-separated (map c-param-id numbered-typs))
2591 ")"
2592 (apply string-append
2593 (map (lambda (t)
2594 (string-append
2595 nl-str
2596 (c-type-decl (car t) (c-param-id t))
2597 ";"))
2598 numbered-typs))
2599 ")")))
2601 (define (c-function-decl param-typs result-typ id scope body)
2602 (let ((numbered-typs (number-from-1 param-typs)))
2603 (let ((function-decl
2604 (c-type-decl result-typ
2605 (string-append
2606 id
2607 " "
2608 (if body
2609 (c-param-list-with-ids numbered-typs)
2610 (c-param-list-with-types param-typs))))))
2611 (if body
2612 (string-append
2613 scope " "
2614 function-decl nl-str
2615 "{" nl-str body "}" nl-str)
2616 (string-append
2617 function-decl ";" nl-str)))))
2619 (define (c-function param-typs result-typ proc-name c-defined? scope)
2620 (let ((proc-val
2621 (if c-defined?
2622 (string-append
2623 c-id-prefix "MLBL(" c-id-prefix "C_LBL_" proc-name ")")
2624 (string-append
2625 c-id-prefix "FAL"))))
2627 (define (make-body set-result-code cleanup?)
2628 (string-append
2629 c-id-prefix "BEGIN_SFUN_BODY" nl-str
2630 (let convert ((numbered-typs (number-from-1 param-typs)))
2631 (if (null? numbered-typs)
2632 (string-append
2633 c-id-prefix
2634 (cond ((void-type? result-typ)
2635 "SFUN_CALL_VOID")
2636 ((scmobj-type? result-typ)
2637 "SFUN_CALL_SCMOBJ")
2638 (else
2639 "SFUN_CALL"))
2640 nl-str)
2641 (let ((numbered-typ (car numbered-typs)))
2642 (string-append
2643 c-id-prefix
2644 "SFUN_ARG("
2645 (number->string (cdr numbered-typ))
2646 ","
2647 (c-argument #t numbered-typ)
2648 ")" nl-str
2649 (convert (cdr numbered-typs))))))
2650 set-result-code
2651 c-id-prefix "END_SFUN_BODY" nl-str))
2653 (add-c-decl
2654 (c-function-decl param-typs
2655 result-typ
2656 proc-name
2657 scope
2658 (c-make-function proc-val
2659 param-typs
2660 result-typ
2661 make-body)))))
2663 (define (fn-param-converter typ)
2664 (let ((function-c-type (c-type-decl typ "")))
2665 (cond ((assoc function-c-type c-interface-converters)
2666 =>
2667 cdr)
2668 (else
2669 (let* ((t
2670 (source-code typ))
2671 (param-typs
2672 (source-code (cadr t)))
2673 (result-typ
2674 (caddr t))
2675 (i
2676 c-interface-converter-count)
2677 (converter
2678 (string-append
2679 c-id-prefix
2680 "converter"
2681 (number->string i))))
2682 (set! c-interface-converter-count
2683 (+ i 1))
2684 (set! c-interface-converters
2685 (cons (cons function-c-type converter)
2686 c-interface-converters))
2687 (c-function
2688 param-typs
2689 result-typ
2690 converter
2691 #f
2692 (string-append c-id-prefix "LOCAL"))
2693 converter)))))
2695 (define (build-c-define param-typs result-typ proc-name scope)
2696 (c-function param-typs result-typ proc-name #t scope))
2698 (define (strip-param-typs param-typs)
2699 param-typs);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2701 (define (build-c-lambda param-typs result-typ proc-name)
2702 (let* ((index
2703 (number->string c-interface-proc-count))
2704 (scheme-name
2705 (string-append module-prefix c-interface-module-name "#" index))
2706 (c-name
2707 (string-append c-id-prefix (scheme-id->c-id scheme-name)))
2708 (arity
2709 (length param-typs))
2710 (stripped-param-typs
2711 (strip-param-typs param-typs)))
2713 (define (make-body set-result-code cleanup?)
2714 (string-append
2715 c-id-prefix
2716 (if cleanup? "BEGIN_CFUN_BODY_CLEANUP" "BEGIN_CFUN_BODY")
2717 nl-str
2718 (c-preproc-define-default-empty
2719 (string-append c-id-prefix "AT_END")
2720 (string-append
2721 (if (valid-c-or-c++-function-id? proc-name)
2722 (let ((c-id
2723 (c-result #f #f))
2724 (indirect-access-result
2725 (type-accessed-indirectly? result-typ))
2726 (call
2727 (string-append
2728 proc-name "("
2729 (comma-separated
2730 (map c-param-id (number-from-1 stripped-param-typs)))
2731 ")")))
2732 (cond ((void-type? result-typ)
2733 (string-append
2734 c-id-prefix
2735 "CFUN_CALL_VOID("
2736 call
2737 ")"))
2738 (indirect-access-result
2739 (if (vector-ref indirect-access-result 1)
2740 (string-append
2741 c-id-prefix
2742 "CFUN_CALL_"
2743 (vector-ref indirect-access-result 0)
2744 "("
2745 (vector-ref indirect-access-result 1)
2746 ","
2747 c-id "_voidstar,"
2748 call
2749 ")")
2750 (string-append
2751 c-id-prefix
2752 "CFUN_CALL_"
2753 (vector-ref indirect-access-result 0)
2754 "("
2755 c-id "_voidstar,"
2756 call
2757 ")")))
2758 (else
2759 (string-append
2760 c-id-prefix
2761 "CFUN_CALL("
2762 c-id ","
2763 call
2764 ")"))))
2765 proc-name)
2766 nl-str))
2767 set-result-code
2768 c-id-prefix
2769 (if cleanup? "END_CFUN_BODY_CLEANUP" "END_CFUN_BODY")
2770 nl-str))
2772 (add-c-proc
2773 (make-c-proc scheme-name
2774 c-name
2775 arity
2776 (c-make-function #f
2777 stripped-param-typs
2778 result-typ
2779 make-body)))
2780 scheme-name))
2782 (define (scheme-id->c-id s)
2783 (let loop1 ((i (- (string-length s) 1)) (lst '()))
2784 (if (>= i 0)
2785 (let ((c (string-ref s i)))
2786 (cond ((char=? c #\_)
2787 (loop1 (- i 1) (cons c (cons c lst))))
2788 ((c-id-subsequent? c)
2789 (loop1 (- i 1) (cons c lst)))
2790 (else
2791 (let ((n (character->unicode c)))
2792 (if (= n 0)
2793 (loop1 (- i 1) (cons #\_ (cons #\0 (cons #\_ lst))))
2794 (let loop2 ((n n) (lst (cons #\_ lst)))
2795 (if (> n 0)
2796 (loop2 (quotient n 16)
2797 (cons (string-ref "0123456789abcdef"
2798 (modulo n 16))
2799 lst))
2800 (loop1 (- i 1) (cons #\_ lst)))))))))
2801 (list->str lst))))
2803 (define (c-id-initial? c) ; c is one of #\A..#\Z, #\a..#\z, #\_
2804 (let ((n (character->unicode c)))
2805 (or (and (>= n 65) (<= n 90))
2806 (and (>= n 97) (<= n 122))
2807 (= n 95))))
2809 (define (c-id-subsequent? c) ; c is one of #\A..#\Z, #\a..#\z, #\_, #\0..#\9
2810 (let ((n (character->unicode c)))
2811 (or (and (>= n 65) (<= n 90))
2812 (and (>= n 97) (<= n 122))
2813 (= n 95)
2814 (and (>= n 48) (<= n 57)))))
2816 (define (valid-c-id? id type?)
2817 (let ((n (string-length id)))
2818 (and (> n 0)
2819 (c-id-initial? (string-ref id 0))
2820 (let loop ((i 1) (depth 0))
2821 (if (< i n)
2822 (let ((c (string-ref id i)))
2823 (cond ((and (< (+ i 2) n)
2824 (char=? #\: c)
2825 (char=? #\: (string-ref id (+ i 1)))
2826 (c-id-initial? (string-ref id (+ i 2))))
2827 (loop (+ i 3) depth))
2828 ((and type?
2829 (< (+ i 1) n)
2830 (char=? #\< c)
2831 (c-id-initial? (string-ref id (+ i 1))))
2832 (loop (+ i 2) (+ depth 1)))
2833 ((and (< (+ i 1) n)
2834 (char=? #\, c)
2835 (c-id-initial? (string-ref id (+ i 1)))
2836 (> depth 0))
2837 (loop (+ i 2) depth))
2838 ((and (char=? #\> c)
2839 (> depth 0))
2840 (loop (+ i 1) (- depth 1)))
2841 ((c-id-subsequent? c)
2842 (loop (+ i 1) depth))
2843 (else
2844 #f)))
2845 (= depth 0))))))
2847 (define (valid-c-or-c++-function-id? id)
2848 (valid-c-id? id #f))
2850 (define (valid-c-or-c++-type-id? id)
2851 (valid-c-id? id #t))
2853 ;;;============================================================================