| blob | b019186752b6bb41a5811a6b95bb950f3b97cd45 |
1 ;;;============================================================================
3 ;;; File: "_ptree2.scm", Time-stamp: <2009-07-04 17:17:17 feeley>
5 ;;; Copyright (c) 1994-2009 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)))
202 (if (and spec
203 (inline-primitive? name env)
204 (or ((proc-obj-inlinable? spec) env)
205 ((proc-obj-expandable? spec) env)))
206 (let* ((std?
207 (standard-proc-obj proc
208 name
209 (node-env oper)))
210 (rtb?
211 (run-time-binding? name
212 (node-env oper)))
213 (generate-original-call
214 (lambda (vars)
215 (new-call
216 source
217 (add-not-inline-primitive? env)
218 (new-ref (node-source oper)
219 (node-env oper)
220 var)
221 (gen-var-refs source env vars))))
222 (generate-run-time-binding-test
223 (lambda (gen-body)
224 (let ((vars (gen-temp-vars source args)))
225 (gen-prc source env
226 vars
227 (new-tst source env
228 (gen-eq-proc source env
229 (new-ref
230 (node-source oper)
231 (node-env oper)
232 var)
233 proc)
234 (gen-body vars)
235 (generate-original-call vars))))))
236 (new-oper
237 (if ((proc-obj-inlinable? spec) env)
238 (cond (std?
239 (new-cst source env
240 spec))
241 (rtb?
242 (generate-run-time-binding-test
243 (lambda (vars)
244 (new-call source env
245 (new-cst source env
246 spec)
247 (gen-var-refs source env vars)))))
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 (lambda (vars)
260 (new-call source env
261 (new-cst source env
262 spec)
263 (gen-var-refs source env vars))))
264 (and (not std?)
265 (eq? proc spec)
266 (lambda ()
267 (gen-eq-proc source env
268 (new-ref
269 (node-source oper)
270 (node-env oper)
271 var)
272 proc))))))
273 (if x
274 (if (and (not std?)
275 (not (eq? proc spec)))
276 (generate-run-time-binding-test
277 (lambda (vars)
278 (new-call source env
279 x
280 (gen-var-refs source env vars))))
281 x)
282 (and std?
283 (new-cst source env
284 spec))))))))
285 (if new-oper
286 (begin
287 (delete-ptree oper)
288 (epc new-oper))
289 (epc oper)))
290 (epc oper)))
291 (epc oper))))
293 ((and (cst? oper)
294 (proc-obj? (cst-val oper)))
295 (let* ((proc
296 (cst-val oper))
297 (spec
298 (specialize-proc proc args (node-env oper)))
299 (source
300 (node-source ptree))
301 (env
302 (node-env ptree))
303 (x
304 (and spec
305 (inline-primitive? (proc-obj-name spec) env)
306 ((proc-obj-expandable? spec) env)
307 ((proc-obj-expand spec)
308 ptree
309 oper
310 args
311 (lambda (vars)
312 (new-call
313 source
314 (add-not-inline-primitive? env)
315 (new-cst source env
316 spec)
317 (gen-var-refs source env vars)))
318 #f))))
319 (epc (or x oper))))
321 (else
322 (epc oper)))))
324 (node-children-set! ptree
325 (cons new-oper
326 args))
328 ptree))
330 (else
331 (compiler-internal-error "epc, unknown parse tree node type"))))
333 (define (gen-prc source env params body)
334 (new-prc source env #f #f params '() #f #f body))
336 (define (gen-disj-multi source env nodes)
337 (if (pair? (cdr nodes))
338 (new-disj source env
339 (car nodes)
340 (gen-disj-multi source env (cdr nodes)))
341 (car nodes)))
343 (define (gen-uniform-type-checks source env vars type-check tail)
345 (define (loop result lst)
346 (if (pair? lst)
347 (loop (new-conj source env
348 (type-check (car lst))
349 result)
350 (cdr lst))
351 result))
353 (cond (tail
354 (loop tail vars))
355 ((pair? vars)
356 (loop (type-check (car vars)) (cdr vars)))
357 (else
358 #f)))
360 (define (gen-temp-vars source args)
361 (let loop ((args args) (rev-vars '()))
362 (if (null? args)
363 (reverse rev-vars)
364 (loop (cdr args)
365 (cons (new-temp-variable source 'temp)
366 rev-vars)))))
368 (define (gen-var-refs source env vars)
369 (map (lambda (var)
370 (new-ref source env
371 var))
372 vars))
374 (define (gen-call-prim-vars source env prim vars)
375 (gen-call-prim source env
376 prim
377 (gen-var-refs source env vars)))
379 (define (gen-call-prim source env prim args)
380 (new-call source (add-not-safe env)
381 (new-cst source env
382 (target.prim-info prim))
383 args))
385 (define (gen-eq-proc source env arg proc)
386 (gen-call-prim source env
387 '##eq?;;;;;;;;;;
388 (list
389 arg
390 (new-cst source env
391 proc))))
393 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
394 ;;
395 ;; Assignment conversion:
396 ;; ---------------------
398 ;; (assignment-convert lst) takes a list of parse-trees and returns a
399 ;; list where each parse-tree has been replaced with an equivalent
400 ;; parse-tree containing no assignments to non-global variables. In
401 ;; the converted parse-tree, 'box' objects are used to implement mutable
402 ;; variables and calls to the procedures:
403 ;;
404 ;; ##box
405 ;; ##unbox
406 ;; ##set-box!
407 ;;
408 ;; are added to create and access the boxes.
410 (define (assignment-convert lst)
411 (map (lambda (ptree) (ac ptree '()))
412 lst))
414 (define (ac ptree mut)
416 (cond ((cst? ptree)
417 ptree)
419 ((ref? ptree)
420 (let ((var (ref-var ptree)))
421 (if (global? var)
422 ptree
423 (let ((x (assq var mut)))
424 (if x
425 (let ((source (node-source ptree)))
426 (var-refs-set! var (ptset-remove (var-refs var) ptree))
427 (gen-call-prim source (node-env ptree)
428 **unbox-sym
429 (list (new-ref source (node-env ptree) (cdr x)))))
430 ptree)))))
432 ((set? ptree)
433 (let ((var (set-var ptree))
434 (source (node-source ptree))
435 (val (ac (set-val ptree) mut)))
436 (if (global? var)
437 (begin
438 (var-sets-set! var (ptset-remove (var-sets var) ptree))
439 (new-set source (node-env ptree)
440 var
441 val))
442 (gen-call-prim source (node-env ptree)
443 **set-box!-sym
444 (list (new-ref source (node-env ptree) (cdr (assq var mut)))
445 val)))))
447 ((def? ptree) ; guaranteed to be a toplevel definition
448 (let ((var (def-var ptree))
449 (val (ac (def-val ptree) mut)))
450 (var-sets-set! var (ptset-remove (var-sets var) ptree))
451 (new-def (node-source ptree) (node-env ptree)
452 var
453 val)))
455 ((tst? ptree)
456 (new-tst (node-source ptree) (node-env ptree)
457 (ac (tst-pre ptree) mut)
458 (ac (tst-con ptree) mut)
459 (ac (tst-alt ptree) mut)))
461 ((conj? ptree)
462 (new-conj (node-source ptree) (node-env ptree)
463 (ac (conj-pre ptree) mut)
464 (ac (conj-alt ptree) mut)))
466 ((disj? ptree)
467 (new-disj (node-source ptree) (node-env ptree)
468 (ac (disj-pre ptree) mut)
469 (ac (disj-alt ptree) mut)))
471 ((prc? ptree)
472 (ac-proc ptree mut))
474 ((app? ptree)
475 (let ((oper (app-oper ptree))
476 (args (app-args ptree)))
477 (if (and (prc? oper) ; applying a lambda-expr is like a 'let'
478 (prc-req-and-opt-parms-only? oper)
479 (= (length (prc-parms oper)) (length args)))
480 (ac-let ptree mut)
481 (new-call (node-source ptree) (node-env ptree)
482 (ac oper mut)
483 (map (lambda (x) (ac x mut)) args)))))
485 ((fut? ptree)
486 (new-fut (node-source ptree) (node-env ptree)
487 (ac (fut-val ptree) mut)))
489 (else
490 (compiler-internal-error "ac, unknown parse tree node type"))))
492 (define (ac-proc ptree mut)
493 (let* ((mut-parms (ac-mutables (prc-parms ptree)))
494 (cloned-mut-parms (clone-vars mut-parms)))
496 (for-each (lambda (var) (var-sets-set! var (ptset-empty)))
497 mut-parms)
499 (for-each (lambda (var) (var-boxed?-set! var #t))
500 cloned-mut-parms)
502 (new-prc (node-source ptree) (node-env ptree)
503 (prc-name ptree)
504 (prc-c-name ptree)
505 (prc-parms ptree)
506 (prc-opts ptree)
507 (prc-keys ptree)
508 (prc-rest? ptree)
509 (new-let ptree
510 ptree
511 cloned-mut-parms
512 (map (lambda (var)
513 (gen-call-prim (var-source var) (node-env ptree)
514 **box-sym
515 (list (new-ref (var-source var)
516 (node-env ptree)
517 var))))
518 mut-parms)
519 (ac (prc-body ptree)
520 (append (pair-up mut-parms cloned-mut-parms) mut))))))
522 (define (ac-let ptree mut)
523 (let* ((proc (app-oper ptree))
524 (vals (app-args ptree))
525 (vars (prc-parms proc))
526 (vals-fv (varset-union-multi (map bound-free-variables vals)))
527 (mut-parms (ac-mutables vars))
528 (cloned-mut-parms (clone-vars mut-parms))
529 (mut (append (pair-up mut-parms cloned-mut-parms) mut)))
531 (for-each (lambda (var) (var-sets-set! var (ptset-empty)))
532 mut-parms)
534 (for-each (lambda (var) (var-boxed?-set! var #t))
535 cloned-mut-parms)
537 (let loop ((l1 vars)
538 (l2 vals)
539 (new-vars '())
540 (new-vals '())
541 (new-body (ac (prc-body proc) mut)))
542 (if (null? l1)
544 (new-let ptree proc new-vars new-vals new-body)
546 (let ((var (car l1))
547 (val (car l2)))
549 (if (memq var mut-parms)
551 (let ((src (node-source val))
552 (env (node-env val))
553 (var* (cdr (assq var mut))))
555 (if (varset-member? var vals-fv)
557 (loop (cdr l1)
558 (cdr l2)
559 (cons var* new-vars)
560 (cons (gen-call-prim src env
561 **box-sym
562 (list (new-cst src env void-object)))
563 new-vals)
564 (new-seq src env
565 (gen-call-prim src env
566 **set-box!-sym
567 (list (new-ref src env var*)
568 (ac val mut)))
569 new-body))
571 (loop (cdr l1)
572 (cdr l2)
573 (cons var* new-vars)
574 (cons (gen-call-prim src env
575 **box-sym
576 (list (ac val mut)))
577 new-vals)
578 new-body)))
580 (loop (cdr l1)
581 (cdr l2)
582 (cons var new-vars)
583 (cons (ac val mut) new-vals)
584 new-body)))))))
586 (define (ac-mutables lst)
587 (keep mutable? lst))
589 (define (clone-vars vars)
590 (map (lambda (var)
591 (let ((cloned-var
592 (make-var (var-name var)
593 #t
594 (ptset-empty)
595 (ptset-empty)
596 (var-source var))))
597 (var-boxed?-set! cloned-var (var-boxed? var))
598 cloned-var))
599 vars))
601 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
602 ;;
603 ;; Beta-reduction:
604 ;; --------------
606 ;; (beta-reduce ptrees) takes a list of parse-trees and transforms
607 ;; each parse-tree with the following transformations:
608 ;;
609 ;; - constant propagation
610 ;; - copy propagation
611 ;; - useless variable elimination
612 ;;
613 ;; It is assumed that the parse-trees have already been assignment-converted.
615 (define beta-reduce #f);***************
617 (set! beta-reduce (lambda (ptrees)
619 (define (vars-with-duplicates->varset vars);********brad avoids this because list->set removes duplicates
620 (let loop ((set (varset-empty)) (lst vars))
621 (if (pair? lst)
622 (loop (varset-adjoin set (car lst)) (cdr lst))
623 set)))
625 (define (pass1) ; transform definitions in dependency order
626 (let* ((defs
627 (keep def? ptrees))
628 (defined-vars
629 (vars-with-duplicates->varset (map def-var (reverse defs))))
630 (depgraph
631 (map (lambda (var)
632 (make-gnode var
633 (varset-union-multi
634 (map (lambda (def)
635 (varset-intersection
636 defined-vars
637 (free-variables (def-val def))))
638 (keep def?
639 (ptset->list (var-sets var)))))))
640 (varset->list defined-vars)))
641 (order
642 (topological-sort
643 (transitive-closure depgraph))))
644 (for-each
645 (lambda (vars)
646 (for-each
647 (lambda (var)
648 (for-each
649 (lambda (def)
650 (node-children-set!
651 def
652 (list (br (def-val def) '() 'need #f))))
653 (keep def? (ptset->list (var-sets var)))))
654 (varset->list vars)))
655 order)))
657 (define (pass2) ; transform non-definitions from top to bottom
658 (let loop ((lst1 ptrees) (lst2 '()))
659 (if (pair? lst1)
660 (let ((ptree (car lst1)))
661 (cond ((not (core? (node-env ptree)))
662 (delete-ptree ptree)
663 (loop (cdr lst1) lst2))
664 ((def? ptree)
665 (loop (cdr lst1) (cons ptree lst2)))
666 (else
667 (loop (cdr lst1) (cons (br ptree
668 '()
669 'need
670 #f)
671 lst2)))))
672 (reverse lst2))))
674 (pass1)
675 (pass2))
676 )
678 (define (br ptree substs reason expansion-limit)
680 (cond ((cst? ptree)
681 (new-cst (node-source ptree) (node-env ptree)
682 (cst-val ptree)))
684 ((ref? ptree)
685 (let ((var (ref-var ptree)))
686 (var-refs-set! var (ptset-remove (var-refs var) ptree))
687 (let ((new-var (var-subst var substs)))
688 (let ((x (var-to-val new-var substs)))
689 (if (and x (or (cst? x) (ref? x)))
690 (clone-ptree x)
691 (new-ref (node-source ptree) (node-env ptree)
692 new-var))))))
694 ((set? ptree) ; variable guaranteed to be a global variable
695 (let ((var (set-var ptree))
696 (val (br (set-val ptree) substs 'need expansion-limit)))
697 (var-sets-set! var (ptset-remove (var-sets var) ptree))
698 (new-set (node-source ptree) (node-env ptree)
699 var
700 val)))
702 ((tst? ptree)
703 (let ((pre (br (tst-pre ptree) substs 'pred expansion-limit)))
704 (if (cst? pre)
705 (if (false-object? (cst-val pre))
706 (begin
707 (delete-ptree pre)
708 (delete-ptree (tst-con ptree))
709 (br (tst-alt ptree) substs reason expansion-limit))
710 (begin
711 (delete-ptree pre)
712 (delete-ptree (tst-alt ptree))
713 (br (tst-con ptree) substs reason expansion-limit)))
714 (new-tst (node-source ptree) (node-env ptree)
715 pre
716 (br (tst-con ptree) substs reason expansion-limit)
717 (br (tst-alt ptree) substs reason expansion-limit)))))
719 ((conj? ptree)
720 (let ((pre (br (conj-pre ptree) substs reason expansion-limit)))
721 (if (cst? pre)
722 (if (false-object? (cst-val pre))
723 (begin
724 (delete-ptree (conj-alt ptree))
725 pre)
726 (begin
727 (delete-ptree pre)
728 (br (conj-alt ptree) substs reason expansion-limit)))
729 (let ((alt (br (conj-alt ptree) substs reason expansion-limit)))
730 (cond ((and (cst? alt)
731 (false-object? (cst-val alt)))
732 (if (side-effects-impossible? pre)
733 (begin
734 ; (and X #f) => #f
735 (delete-ptree pre)
736 alt)
737 (begin
738 ; (and X #f) => (begin X #f)
739 ; this transform should be generalized
740 (new-seq (node-source ptree) (node-env ptree)
741 pre
742 alt))))
743 ((and (cst? alt)
744 (not (false-object? (cst-val alt)))
745 (eq? reason 'pred))
746 ; (if (and X non-#f) ...) => (if X ...)
747 (delete-ptree alt)
748 pre)
749 (else
750 (new-conj (node-source ptree) (node-env ptree)
751 pre
752 alt)))))))
754 ((disj? ptree)
755 (let ((pre (br (disj-pre ptree) substs reason expansion-limit)))
756 (if (cst? pre)
757 (if (false-object? (cst-val pre))
758 (begin
759 (delete-ptree pre)
760 (br (disj-alt ptree) substs reason expansion-limit))
761 (begin
762 (delete-ptree (disj-alt ptree))
763 pre))
764 (let ((alt (br (disj-alt ptree) substs reason expansion-limit)))
765 (if (and (cst? alt)
766 (false-object? (cst-val alt)))
767 (begin
768 ; (or X #f) => X
769 (delete-ptree alt)
770 pre)
771 (new-disj (node-source ptree) (node-env ptree)
772 pre
773 alt))))))
775 ((prc? ptree)
776 (new-prc (node-source ptree) (node-env ptree)
777 (prc-name ptree)
778 (prc-c-name ptree)
779 (prc-parms ptree)
780 (prc-opts ptree)
781 (prc-keys ptree)
782 (prc-rest? ptree)
783 (br (prc-body ptree) substs 'need expansion-limit)))
785 ((br-let? ptree)
786 (br-let ptree substs reason expansion-limit))
788 ((app? ptree)
789 (let ((oper (app-oper ptree))
790 (args (app-args ptree)))
791 (if (or (cst? oper) (ref? oper))
792 (let ((br-oper (br oper substs 'need expansion-limit)))
793 ; at this point (or (cst? br-oper) (ref? br-oper))
794 (or (br-app-inline ptree br-oper args substs reason expansion-limit)
795 (br-app-simplify ptree br-oper args substs reason expansion-limit)))
796 (br-app ptree oper args substs reason expansion-limit))))
798 ((fut? ptree)
799 (new-fut (node-source ptree) (node-env ptree)
800 (br (fut-val ptree) substs 'need expansion-limit)))
802 (else
803 (compiler-internal-error "br, unknown parse tree node type"))))
805 (define (var-subst var substs)
806 (if (null? substs)
807 var
808 (let ((couple (car substs)))
809 (if (eq? (car couple) var)
810 (if (ref? (cdr couple))
811 (var-subst (ref-var (cdr couple)) (cdr substs))
812 var)
813 (var-subst var (cdr substs))))))
815 (define (var-to-val var substs)
816 (if (global? var)
817 (global-single-def var)
818 (let ((x (assq var substs)))
819 (if x (cdr x) #f))))
821 (define (br-let? ptree)
822 (and (app? ptree)
823 (let ((oper (app-oper ptree))
824 (args (app-args ptree)))
825 (and (prc? oper) ; applying a lambda-expr is like a 'let'
826 (prc-req-and-opt-parms-only? oper)
827 (= (length (prc-parms oper)) (length args))))))
829 (define (br-app ptree oper args substs reason expansion-limit)
831 (if (and (br-let? oper)
832 (let ((body (prc-body (app-oper oper))))
833 (or (cst? body)
834 (and (ref? body)
835 (or (bound? (ref-var body))
836 (global-singly-bound? body))))))
838 ;; let-floating transformation when the code is of the
839 ;; form:
840 ;;
841 ;; ((let (...) var) E1 E2) -> (let (...) (var E1 E2))
843 (let ((proc (app-oper oper)))
844 (br (new-call (node-source oper) (node-env oper)
845 (new-prc (node-source proc) (node-env proc)
846 (prc-name proc)
847 (prc-c-name proc)
848 (prc-parms proc)
849 (prc-opts proc)
850 (prc-keys proc)
851 (prc-rest? proc)
852 (new-call (node-source ptree) (node-env ptree)
853 (prc-body proc)
854 args))
855 (app-args oper))
856 substs
857 reason
858 expansion-limit))
860 (new-call (node-source ptree) (node-env ptree)
861 (br oper substs 'need expansion-limit)
862 (map (lambda (arg) (br arg substs 'need expansion-limit)) args))))
864 (define (br-let ptree substs reason expansion-limit)
865 (let* ((proc
866 (app-oper ptree))
867 (vals
868 (app-args ptree))
869 (vars
870 (prc-parms proc))
871 (vars-varset
872 (list->varset vars))
873 (var-val-map
874 (pair-up vars vals))
875 (new-substs
876 (br-extend-substs vars vals substs))
877 (br-vals
878 (map (lambda (x) (br x new-substs 'need expansion-limit)) vals))
879 (new-substs2
880 (br-extend-substs vars br-vals substs))
881 (new-body
882 (br (prc-body proc) new-substs2 reason expansion-limit)))
884 (define (var->val var) (cdr (assq var var-val-map)))
886 (define (reachable-vars-from starting-point)
887 (let loop ((old-reachable-vars
888 (varset-empty))
889 (reachable-vars
890 (varset-intersection
891 vars-varset
892 starting-point)))
893 (if (varset-equal? reachable-vars old-reachable-vars)
894 reachable-vars
895 (loop reachable-vars
896 (varset-union-multi
897 (cons reachable-vars
898 (map (lambda (var)
899 (varset-intersection
900 vars-varset
901 (bound-free-variables (var->val var))))
902 (varset->list
903 (varset-difference reachable-vars
904 old-reachable-vars)))))))))
906 ; remove useless bindings
908 (let ((reachable-vars
909 (reachable-vars-from
910 (varset-union-multi
911 (cons (bound-free-variables new-body)
912 (map (lambda (br-val)
913 (if (prc? br-val)
914 (varset-empty) ; reachable only if called
915 (bound-free-variables br-val)))
916 br-vals))))))
917 (let loop ((l1 vars)
918 (l2 br-vals)
919 (new-vars '())
920 (new-vals '()))
921 (if (null? l1)
922 (new-let ptree
923 proc
924 (reverse new-vars)
925 (reverse new-vals)
926 new-body)
927 (let ((var (car l1))
928 (br-val (car l2)))
929 (if (and (not (varset-member? var reachable-vars))
930 (or (cst? br-val)
931 (ref? br-val)
932 (prc? br-val)))
933 (begin
934 (delete-ptree br-val)
935 (loop (cdr l1)
936 (cdr l2)
937 new-vars
938 new-vals))
939 (loop (cdr l1)
940 (cdr l2)
941 (cons var new-vars)
942 (cons br-val new-vals)))))))))
944 (define (br-extend-substs vars vals substs)
945 (let loop ((l1 vars)
946 (l2 vals)
947 (new-substs substs))
948 (if (null? l1)
949 new-substs
950 (let ((var (car l1))
951 (val (car l2)))
952 (cond ((or (cst? val)
953 (and (ref? val)
954 (or (bound? (ref-var val))
955 (global-singly-bound? val)))
956 (and (prc? val)
957 (ptset-every? oper-pos? (var-refs var))))
958 (loop (cdr l1)
959 (cdr l2)
960 (cons (cons var val) new-substs)))
961 (else
962 (loop (cdr l1)
963 (cdr l2)
964 new-substs)))))))
966 (define (br-app-inline ptree br-oper args substs reason expansion-limit)
968 ; invariant: (or (cst? br-oper) (ref? br-oper))
970 (and (ref? br-oper)
971 (let* ((var (ref-var br-oper))
972 (val (var-to-val var substs)))
974 (define (inline-procedure new-expansion-limit)
975 (let ((cloned-oper (clone-ptree val)))
976 (delete-ptree br-oper)
977 (br-app ptree cloned-oper args substs reason
978 new-expansion-limit)))
980 (and val
981 (prc? val)
982 (inline? (node-env val))
983 (if (and (bound? var)
984 (= (ptset-size (var-refs var)) 1)
985 (not (varset-member? var (bound-free-variables val))))
987 ; Procedure is referenced once and it is not direcly
988 ; recursive so inline it without changing the
989 ; expansion limit (the original code will be removed
990 ; by br-let).
992 (inline-procedure expansion-limit)
994 ; Procedure is referenced more than once or it is
995 ; directly recursive so we inline it only if we
996 ; don't exceed the expansion limit.
998 (let* ((size-val
999 (ptree-size val))
1000 (size-ptree
1001 (ptree-size ptree))
1002 (new-limit
1003 (- (if expansion-limit
1004 (car expansion-limit)
1005 (quotient (* (inlining-limit (node-env ptree))
1006 size-ptree)
1007 100))
1008 (- size-val 1))))
1009 (and (>= new-limit 0)
1010 (if expansion-limit
1011 (begin
1012 (set-car! expansion-limit new-limit)
1013 (inline-procedure expansion-limit))
1014 (inline-procedure (list new-limit))))))))))
1016 (define (br-app-simplify ptree br-oper args substs reason expansion-limit)
1018 ; invariant: (or (cst? br-oper) (ref? br-oper))
1020 (let* ((br-args
1021 (map (lambda (arg) (br arg substs 'need expansion-limit)) args))
1022 (proc
1023 (and (constant-fold? (node-env ptree))
1024 (specialize-app br-oper br-args (node-env ptree))))
1025 (simp
1026 (and proc
1027 (nb-args-conforms? (length args) (proc-obj-call-pat proc))
1028 (proc-obj-simplify proc)))
1029 (simplified-ptree
1030 (and simp
1031 (simp ptree br-args))))
1032 (if simplified-ptree
1033 (begin
1034 (delete-ptree br-oper)
1035 (for-each delete-ptree br-args)
1036 simplified-ptree)
1037 (new-call (node-source ptree) (node-env ptree)
1038 br-oper
1039 br-args))))
1041 (define (ptree-size ptree)
1042 (let loop ((lst (node-children ptree)) (n 1))
1043 (if (null? lst)
1044 n
1045 (loop (cdr lst) (+ n (ptree-size (car lst)))))))
1047 (define (side-effects-impossible? ptree)
1049 (cond ((cst? ptree)
1050 #t)
1052 ((ref? ptree)
1053 #t)
1055 ((set? ptree) ; variable guaranteed to be a global variable
1056 #f)
1058 ((tst? ptree)
1059 (and (side-effects-impossible? (tst-pre ptree))
1060 (side-effects-impossible? (tst-con ptree))
1061 (side-effects-impossible? (tst-alt ptree))))
1063 ((conj? ptree)
1064 (and (side-effects-impossible? (conj-pre ptree))
1065 (side-effects-impossible? (conj-alt ptree))))
1067 ((disj? ptree)
1068 (and (side-effects-impossible? (disj-pre ptree))
1069 (side-effects-impossible? (disj-alt ptree))))
1071 ((prc? ptree)
1072 #t)
1074 ((app? ptree)
1075 (let ((oper (app-oper ptree))
1076 (args (app-args ptree)))
1077 (and (every? side-effects-impossible? args)
1078 (if (and (prc? oper) ; applying a lambda-expr is like a 'let'
1079 (prc-req-and-opt-parms-only? oper)
1080 (= (length (prc-parms oper)) (length args)))
1081 (side-effects-impossible? (prc-body oper))
1082 (let ((proc (app->specialized-proc ptree)))
1083 (and proc
1084 (not (proc-obj-side-effects? proc))))))))
1086 ((fut? ptree)
1087 (side-effects-impossible? (fut-val ptree)))
1089 (else
1090 (compiler-internal-error "side-effects-impossible?, unknown parse tree node type"))))
1092 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1093 ;;
1094 ;; Lambda-lifting procedure:
1095 ;; ------------------------
1097 ;; (lambda-lift lst) takes a list of parse-trees and returns a list
1098 ;; where each parse-tree has been modified so that some of its
1099 ;; procedures (i.e. lambda-expressions) are replaced with weaker ones
1100 ;; (i.e. lambda-expressions having fewer or no closed variables). It
1101 ;; is assumed that 'ptree' has already been assignment-converted. The
1102 ;; only procedures that are lambda-lifted are named procedures and
1103 ;; procedures which are passed to some primitive higher-order functions
1104 ;; (such as call-with-current-continuation).
1106 (define (lambda-lift lst)
1107 (for-each (lambda (ptree)
1108 (ll! ptree (varset-empty) '()))
1109 lst)
1110 lst)
1112 (define (ll! ptree cst-procs env)
1114 (define (new-env env vars)
1115 (define (loop i l)
1116 (if (pair? l)
1117 (let ((var (car l)))
1118 (cons (cons var (cons (ptset-size (var-refs var)) i))
1119 (loop (+ i 1) (cdr l))))
1120 env))
1121 (loop (length env) vars))
1123 (cond ((or (cst? ptree)
1124 (ref? ptree)
1125 (set? ptree)
1126 (def? ptree) ; guaranteed to be a toplevel definition
1127 (tst? ptree)
1128 (conj? ptree)
1129 (disj? ptree)
1130 (fut? ptree))
1131 (for-each (lambda (child) (ll! child cst-procs env))
1132 (node-children ptree)))
1134 ((prc? ptree)
1135 (ll! (prc-body ptree) cst-procs (new-env env (prc-parms ptree))))
1137 ((app? ptree)
1138 (let ((oper (app-oper ptree))
1139 (args (app-args ptree)))
1140 (if (and (prc? oper) ; applying a lambda-expr is like a 'let'
1141 (prc-req-and-opt-parms-only? oper)
1142 (= (length (prc-parms oper)) (length args)))
1143 (ll!-let ptree cst-procs (new-env env (prc-parms oper)))
1144 (ll!-call ptree cst-procs env))))
1146 (else
1147 (compiler-internal-error "ll!, unknown parse tree node type"))))
1149 (define (ll!-call ptree cst-procs env)
1151 (for-each (lambda (child) (ll! child cst-procs env))
1152 (node-children ptree))
1154 (let* ((oper (app-oper ptree))
1155 (proc (cond ((cst? oper) (cst-val oper))
1156 ((ref? oper) (global-proc-obj oper))
1157 (else #f))))
1158 (if (proc-obj? proc)
1159 (let* ((lift-pat
1160 (proc-obj-lift-pat proc))
1161 (receiver-arg-pos
1162 (modulo (quotient lift-pat 1000) 10))
1163 (min-nb-args
1164 (modulo (quotient lift-pat 100) 10))
1165 (nb-req-and-opt-parms
1166 (modulo (quotient lift-pat 10) 10))
1167 (max-lifted-vars
1168 (modulo lift-pat 10))
1169 (args
1170 (app-args ptree))
1171 (nb-args
1172 (length args)))
1173 (if (and (< 0 receiver-arg-pos)
1174 (<= min-nb-args nb-args))
1175 (let ((receiver
1176 (list-ref args (- receiver-arg-pos 1))))
1177 (if (and (prc? receiver)
1178 (lambda-lift? (node-env receiver))
1179 (prc-req-and-opt-parms-only? receiver)
1180 (<= nb-req-and-opt-parms
1181 (length (prc-parms receiver)))
1182 (= (- (length (prc-parms receiver))
1183 nb-req-and-opt-parms)
1184 (- nb-args min-nb-args)))
1185 (let ((vars
1186 (ll-lifted-vars (bound-free-variables receiver)
1187 cst-procs
1188 env)))
1189 (if (and (not (null? vars))
1190 (<= (+ (length vars) (- nb-args min-nb-args))
1191 max-lifted-vars))
1192 (let ((cloned-vars (clone-vars vars)))
1194 ;; modify call site
1196 (define (new-ref* var)
1197 (new-ref (var-source var) (node-env ptree) var))
1199 (node-children-set!
1200 ptree
1201 (cons oper
1202 (append (take args min-nb-args)
1203 (map new-ref* vars)
1204 (drop args min-nb-args))))
1206 ;; modify receiver procedure
1208 (prc-parms-set!
1209 receiver
1210 (append (take (prc-parms receiver)
1211 nb-req-and-opt-parms)
1212 cloned-vars
1213 (drop (prc-parms receiver)
1214 nb-req-and-opt-parms)))
1215 (for-each (lambda (x) (var-bound-set! x receiver))
1216 cloned-vars)
1217 (node-fv-invalidate! receiver)
1218 (for-each (lambda (x y) (var-clone-set! x y))
1219 vars
1220 cloned-vars)
1221 (ll-rename! receiver)
1222 (for-each (lambda (x) (var-clone-set! x #f))
1223 vars)))))))))))
1225 (define (ll!-let ptree cst-procs env)
1226 (let* ((proc (app-oper ptree))
1227 (vals (app-args ptree))
1228 (vars (prc-parms proc))
1229 (var-val-map (pair-up vars vals)))
1231 (define (var->val var) (cdr (assq var var-val-map)))
1233 (define (liftable-proc-vars vars)
1234 (let loop ((cst-proc-vars-list
1235 (keep (lambda (var)
1236 (let ((val (var->val var)))
1237 (and (prc? val)
1238 (lambda-lift? (node-env val))
1239 (ptset-every? oper-pos? (var-refs var)))))
1240 vars)))
1241 (let* ((cst-proc-vars
1242 (list->varset cst-proc-vars-list))
1243 (non-cst-proc-vars-list
1244 (keep (lambda (var)
1245 (let ((val (var->val var)))
1246 (and (prc? val)
1247 (not (varset-member? var cst-proc-vars)))))
1248 vars))
1249 (non-cst-proc-vars
1250 (list->varset non-cst-proc-vars-list))
1251 (cst-proc-vars-list*
1252 (keep (lambda (var)
1253 (not (varset-intersects?
1254 (bound-free-variables (var->val var))
1255 non-cst-proc-vars)))
1256 cst-proc-vars-list)))
1257 (if (= (length cst-proc-vars-list)
1258 (length cst-proc-vars-list*))
1259 cst-proc-vars-list
1260 (loop cst-proc-vars-list*)))))
1262 (define (transitively-closed-bound-free-variables vars)
1263 (let ((tcbfv-map
1264 (map (lambda (var)
1265 (cons var (bound-free-variables (var->val var))))
1266 vars)))
1267 (let loop ()
1268 (let ((changed? #f))
1269 (for-each (lambda (var-tcbfv)
1270 (let ((tcbfv (cdr var-tcbfv)))
1271 (let loop2 ((l (varset->list tcbfv))
1272 (fv tcbfv))
1273 (if (null? l)
1274 (if (not (= (varset-size fv)
1275 (varset-size tcbfv)))
1276 (begin
1277 (set-cdr! var-tcbfv fv)
1278 (set! changed? #t)))
1279 (let ((x (assq (car l) tcbfv-map)))
1280 (loop2 (cdr l)
1281 (if x
1282 (varset-union fv (cdr x))
1283 fv)))))))
1284 tcbfv-map)
1285 (if changed?
1286 (loop)
1287 tcbfv-map)))))
1289 (let* ((tcbfv-map
1290 (transitively-closed-bound-free-variables
1291 (liftable-proc-vars vars)))
1292 (cst-proc-vars-list
1293 (map car tcbfv-map))
1294 (cst-procs*
1295 (varset-union (list->varset cst-proc-vars-list) cst-procs)))
1297 (define (var->tcbfv var) (cdr (assq var tcbfv-map)))
1299 (define (lifted-vars var)
1300 (ll-lifted-vars (var->tcbfv var) cst-procs* env))
1302 (define (lift-app! var)
1303 (let* ((val (var->val var))
1304 (vars (lifted-vars var)))
1305 (if (not (null? vars))
1306 (for-each (lambda (oper)
1307 (let ((node (node-parent oper)))
1309 (define (new-ref* var)
1310 (new-ref (var-source var) (node-env node) var))
1312 (node-children-set! node
1313 (cons (app-oper node)
1314 (append (map new-ref* vars)
1315 (app-args node))))))
1316 (ptset->list (var-refs var))))))
1318 (define (lift-prc! var)
1319 (let* ((val (var->val var))
1320 (vars (lifted-vars var)))
1321 (if (not (null? vars))
1322 (let ((cloned-vars (clone-vars vars)))
1323 (prc-parms-set! val (append cloned-vars (prc-parms val)))
1324 (for-each (lambda (x) (var-bound-set! x val)) cloned-vars)
1325 (node-fv-invalidate! val)
1326 (for-each (lambda (x y) (var-clone-set! x y)) vars cloned-vars)
1327 (ll-rename! val)
1328 (for-each (lambda (x) (var-clone-set! x #f)) vars)))))
1330 (for-each lift-app! cst-proc-vars-list)
1331 (for-each lift-prc! cst-proc-vars-list)
1332 (for-each (lambda (node) (ll! node cst-procs* env)) vals)
1333 (ll! (prc-body proc) cst-procs* env))))
1335 (define (ll-lifted-vars bfv cst-procs env)
1337 (define (order-vars vars)
1338 (map car
1339 (sort-list (map (lambda (var) (assq var env)) vars)
1340 (lambda (x y)
1341 ;;;; (if (= (cadr x) (cadr y))
1342 ;;;; (< (cddr x) (cddr y))
1343 ;;;; (< (cadr x) (cadr y)))
1344 (< (cddr x) (cddr y))))))
1346 (order-vars
1347 (varset->list (varset-difference bfv cst-procs))))
1349 (define (ll-rename! ptree)
1351 (if (ref? ptree)
1352 (let* ((var (ref-var ptree))
1353 (x (var-clone var)))
1354 (if x
1355 (begin
1356 (var-refs-set! var (ptset-remove (var-refs var) ptree))
1357 (var-refs-set! x (ptset-adjoin (var-refs x) ptree))
1358 (ref-var-set! ptree x)))))
1360 (node-fv-set! ptree #t)
1361 (node-bfv-set! ptree #t)
1363 (for-each (lambda (child) (ll-rename! child))
1364 (node-children ptree)))
1366 ;;;----------------------------------------------------------------------------
1367 ;;
1368 ;; Debugging stuff:
1370 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1371 ;;
1372 ;; (parse-tree->expression ptree) returns the Scheme expression corresponding to
1373 ;; the parse tree 'ptree'.
1375 (define (parse-tree->expression ptree)
1376 (se ptree '() (list 0)))
1378 (define (se ptree env num)
1380 (cond ((cst? ptree)
1381 (let ((val (cst-val ptree)))
1382 (se-constant val)))
1384 ((ref? ptree)
1385 (se-var->id (ref-var ptree) env))
1387 ((set? ptree)
1388 (list set!-sym
1389 (se-var->id (set-var ptree) env)
1390 (se (set-val ptree) env num)))
1392 ((def? ptree)
1393 (list define-sym
1394 (se-var->id (def-var ptree) env)
1395 (se (def-val ptree) env num)))
1397 ((tst? ptree)
1398 (list if-sym (se (tst-pre ptree) env num)
1399 (se (tst-con ptree) env num)
1400 (se (tst-alt ptree) env num)))
1402 ((conj? ptree)
1403 (list and-sym (se (conj-pre ptree) env num)
1404 (se (conj-alt ptree) env num)))
1406 ((disj? ptree)
1407 (list or-sym (se (disj-pre ptree) env num)
1408 (se (disj-alt ptree) env num)))
1410 ((prc? ptree)
1411 (let ((new-env (se-rename ptree env num)))
1412 (list lambda-sym
1413 (se-parameters (prc-parms ptree)
1414 (prc-opts ptree)
1415 (prc-keys ptree)
1416 (prc-rest? ptree)
1417 new-env
1418 num)
1419 (se (prc-body ptree) new-env num))))
1421 ((app? ptree)
1422 (let ((oper (app-oper ptree))
1423 (args (app-args ptree)))
1424 (if (and (prc? oper) ; applying a lambda-expr is like a 'let'
1425 (prc-req-and-opt-parms-only? oper)
1426 (= (length (prc-parms oper)) (length args)))
1427 (let ((new-env (se-rename oper env num)))
1428 (list
1429 (if (varset-intersects?
1430 (list->varset (prc-parms oper))
1431 (varset-union-multi (map bound-free-variables args)))
1432 letrec-sym
1433 let-sym)
1434 (se-bindings (prc-parms oper) args new-env num)
1435 (se (prc-body oper) new-env num)))
1436 (map (lambda (x) (se x env num)) (cons oper args)))))
1438 ((fut? ptree)
1439 (list future-sym (se (fut-val ptree) env num)))
1441 (else
1442 (compiler-internal-error "se, unknown parse tree node type"))))
1444 (define use-actual-primitives-in-expression? #t)
1446 (define (se-constant val)
1447 (if (self-evaluating? val)
1448 val
1449 (list quote-sym
1450 (if (proc-obj? val)
1451 (if use-actual-primitives-in-expression?
1452 (eval (string->symbol (proc-obj-name val)))
1453 (list '*primitive* (proc-obj-name val)))
1454 val))))
1456 (define (se-var->id var env)
1457 (let ((id (let ((x (assq var env)))
1458 (if x (cdr x) (var-name var)))))
1459 ;; for debugging:
1460 ;; (string->symbol
1461 ;; (string-append (symbol->string id)
1462 ;; ":"
1463 ;; (number->string (##object->serial-number var))))
1464 id))
1466 (define use-dotted-rest-parameter-when-possible? #t)
1468 (define (se-parameters parms opts keys rest? env num)
1470 (define (se-required parms n)
1471 (if (= n 0)
1472 (se-opts parms)
1473 (let ((parm (se-var->id (car parms) env)))
1474 (cons parm (se-required (cdr parms) (- n 1))))))
1476 (define (se-opts parms)
1477 (if (null? opts)
1478 (se-rest-and-keys parms)
1479 (cons optional-object
1480 (let loop ((parms parms) (opts opts))
1481 (if (null? opts)
1482 (se-rest-and-keys parms)
1483 (let ((parm (se-var->id (car parms) env)))
1484 (cons (list parm (se-constant (car opts)))
1485 (loop (cdr parms) (cdr opts)))))))))
1487 (define (se-rest-and-keys parms)
1489 (define (se-rest-at-end parm)
1490 (if use-dotted-rest-parameter-when-possible?
1491 parm
1492 (cons rest-object (cons parm '()))))
1494 (if rest?
1495 (let ((parm (se-var->id (car (last-pair parms)) env)))
1496 (if (not keys)
1497 (se-rest-at-end parm)
1498 (if (eq? rest? 'dsssl)
1499 (cons rest-object (cons parm (se-keys parms '())))
1500 (se-keys parms (se-rest-at-end parm)))))
1501 (se-keys parms '())))
1503 (define (se-keys parms tail)
1504 (if (not keys)
1505 tail
1506 (cons key-object
1507 (let loop ((parms parms) (keys keys))
1508 (if (null? keys)
1509 tail
1510 (let ((parm (se-var->id (car parms) env)))
1511 (cons (list parm (se-constant (cdr (car keys))))
1512 (loop (cdr parms) (cdr keys)))))))))
1514 (se-required parms
1515 (- (length parms)
1516 (length opts)
1517 (if keys (length keys) 0)
1518 (if rest? 1 0))))
1520 (define (se-bindings vars vals env num)
1521 (if (null? vars)
1522 '()
1523 (cons (list (se-var->id (car vars) env) (se (car vals) env num))
1524 (se-bindings (cdr vars) (cdr vals) env num))))
1526 (define (se-rename proc env num)
1527 (let* ((parms
1528 (prc-parms proc))
1529 (free-vars
1530 (varset->list (free-variables (prc-body proc))))
1531 (p-names
1532 (map var-name parms))
1533 (fv-names
1534 (map var-name free-vars))
1535 (names
1536 (append p-names fv-names))
1537 (n
1538 (length p-names)))
1540 (define (conflict? var i)
1541 (let* ((p (pos-in-list var free-vars))
1542 (k (if p (+ p n) i)))
1543 (let loop ((lst names) (j 0))
1544 (if (null? lst)
1545 #f
1546 (let ((x (car lst)))
1547 (if (and (not (= i j))
1548 (not (= k j))
1549 (eq? x (var-name var)))
1550 #t
1551 (loop (cdr lst) (+ j 1))))))))
1553 (define (rename vars i)
1554 (if (null? vars)
1555 env
1556 (let* ((var (car vars))
1557 (id (var-name var)))
1558 (cons (cons var
1559 (if (conflict? var i)
1560 (begin
1561 (set-car! num (+ (car num) 1))
1562 (string->symbol
1563 (string-append (symbol->string id)
1564 "#"
1565 (number->string (car num)))))
1566 id))
1567 (rename (cdr vars) (+ i 1))))))
1570 (rename parms 0)))
1572 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1574 ;; C-interface stuff:
1576 (define (c-interface-begin module-name)
1577 (set! c-interface-module-name module-name)
1578 (set! c-interface-proc-count 0)
1579 (set! c-interface-obj-count 0)
1580 (set! c-interface-types scheme-to-c-notation)
1581 (set! c-interface-release-fns '())
1582 (set! c-interface-release-fn-count 0)
1583 (set! c-interface-converters '())
1584 (set! c-interface-converter-count 0)
1585 (set! c-interface-decls '())
1586 (set! c-interface-procs '())
1587 (set! c-interface-inits '())
1588 (set! c-interface-objs '())
1589 #f)
1591 (define (c-interface-end)
1592 (let ((i (make-c-intf (reverse c-interface-decls)
1593 (reverse c-interface-procs)
1594 (reverse c-interface-inits)
1595 (reverse c-interface-objs))))
1596 (set! c-interface-module-name #f)
1597 (set! c-interface-proc-count #f)
1598 (set! c-interface-obj-count #f)
1599 (set! c-interface-types #f)
1600 (set! c-interface-release-fns #f)
1601 (set! c-interface-release-fn-count #f)
1602 (set! c-interface-converters #f)
1603 (set! c-interface-converter-count #f)
1604 (set! c-interface-decls #f)
1605 (set! c-interface-procs #f)
1606 (set! c-interface-inits #f)
1607 (set! c-interface-objs #f)
1608 i))
1610 (define c-interface-module-name #f)
1611 (define c-interface-proc-count #f)
1612 (define c-interface-obj-count #f)
1613 (define c-interface-types #f)
1614 (define c-interface-release-fns #f)
1615 (define c-interface-release-fn-count #f)
1616 (define c-interface-converters #f)
1617 (define c-interface-converter-count #f)
1618 (define c-interface-decls #f)
1619 (define c-interface-procs #f)
1620 (define c-interface-inits #f)
1621 (define c-interface-objs #f)
1623 (define (add-c-type name type)
1624 (set! c-interface-types
1625 (cons (cons name type) c-interface-types))
1626 #f)
1628 (define (add-c-decl declaration-string)
1629 (set! c-interface-decls
1630 (cons declaration-string c-interface-decls))
1631 #f)
1633 (define (add-c-proc c-proc)
1634 (set! c-interface-proc-count (+ c-interface-proc-count 1))
1635 (set! c-interface-procs
1636 (cons c-proc c-interface-procs))
1637 #f)
1639 (define (add-c-init initialization-code-string)
1640 (set! c-interface-inits
1641 (cons initialization-code-string c-interface-inits))
1642 #f)
1644 (define (add-c-obj obj)
1645 (set! c-interface-obj-count (+ c-interface-obj-count 1))
1646 (set! c-interface-objs
1647 (cons obj c-interface-objs))
1648 #f)
1650 (define (make-c-intf decls procs inits objs) (vector decls procs inits objs))
1651 (define (c-intf-decls c-intf) (vector-ref c-intf 0))
1652 (define (c-intf-decls-set! c-intf x) (vector-set! c-intf 0 x))
1653 (define (c-intf-procs c-intf) (vector-ref c-intf 1))
1654 (define (c-intf-procs-set! c-intf x) (vector-set! c-intf 1 x))
1655 (define (c-intf-inits c-intf) (vector-ref c-intf 2))
1656 (define (c-intf-inits-set! c-intf x) (vector-set! c-intf 2 x))
1657 (define (c-intf-objs c-intf) (vector-ref c-intf 3))
1658 (define (c-intf-objs-set! c-intf x) (vector-set! c-intf 3 x))
1660 (define (make-c-proc scheme-name c-name arity body)
1661 (vector c-proc-tag scheme-name c-name arity body))
1663 (define c-proc-tag (list 'c-proc))
1665 (define (c-proc? x)
1666 (and (vector? x)
1667 (> (vector-length x) 0)
1668 (eq? (vector-ref x 0) c-proc-tag)))
1670 (define (c-proc-scheme-name x) (vector-ref x 1))
1671 (define (c-proc-c-name x) (vector-ref x 2))
1672 (define (c-proc-arity x) (vector-ref x 3))
1673 (define (c-proc-body x) (vector-ref x 4))
1675 (define (**c-define-type-expr? source)
1676 (and (match **c-define-type-sym -3 source)
1677 (or (let ((len (length (source-code source))))
1678 (and (or (= len 3) (= len 6))
1679 (proper-c-type-definition? source)))
1680 (ill-formed-special-form source))))
1682 (define (proper-c-type-definition? source)
1683 (let* ((code (source-code source))
1684 (name-source (cadr code))
1685 (name (source-code name-source)))
1686 (cond ((not (symbol-object? name))
1687 (pt-syntax-error
1688 name-source
1689 "C type's name must be an identifier"))
1690 ((assq name c-interface-types)
1691 (pt-syntax-error
1692 name-source
1693 "C type's name is already defined"))
1694 ((= (length code) 3)
1695 (let ((type-source (caddr code)))
1696 (check-c-type type-source #f #t))) ; allow all types
1697 (else
1698 (let* ((ctype-source (caddr code))
1699 (ctype (source-code ctype-source))
1700 (ctos-source (cadddr code))
1701 (ctos (source-code ctos-source))
1702 (stoc-source (cadddr (cdr code)))
1703 (stoc (source-code stoc-source))
1704 (cleanup-source (cadddr (cddr code)))
1705 (cleanup (source-code cleanup-source)))
1706 (cond ((not (string? ctype))
1707 (pt-syntax-error
1708 ctype-source
1709 "Second argument to 'c-define-type' must be a string"))
1710 ((not (string? ctos))
1711 (pt-syntax-error
1712 ctos-source
1713 "Third argument to 'c-define-type' must be a string"))
1714 ((not (valid-c-or-c++-function-id? ctos))
1715 (pt-syntax-error
1716 ctos-source
1717 "Ill-formed C function identifier"))
1718 ((not (string? stoc))
1719 (pt-syntax-error
1720 stoc-source
1721 "Fourth argument to 'c-define-type' must be a string"))
1722 ((not (valid-c-or-c++-function-id? stoc))
1723 (pt-syntax-error
1724 stoc-source
1725 "Ill-formed C function identifier"))
1726 ((not (or (false-object? cleanup)
1727 (eq? cleanup #t)))
1728 (pt-syntax-error
1729 stoc-source
1730 "Fifth argument to 'c-define-type' must be a boolean"))
1731 (else
1732 #t)))))))
1734 (define (c-type-definition-name source)
1735 (let ((code (source-code source)))
1736 (cadr code)))
1738 (define (c-type-definition-type source)
1739 (let ((code (source-code source)))
1740 (if (= (length code) 3)
1741 (vector 'alias
1742 (caddr code))
1743 (vector 'c-type
1744 (source-code (caddr code))
1745 (source-code (cadddr code))
1746 (source-code (cadddr (cdr code)))
1747 (source-code (cadddr (cddr code)))))))
1749 (define (**c-declare-expr? source)
1750 (and (match **c-declare-sym 2 source)
1751 (let ((code (source-code source)))
1752 (or (string? (source-code (cadr code)))
1753 (pt-syntax-error
1754 source
1755 "Argument to 'c-declare' must be a string")))))
1757 (define (c-declaration-body source)
1758 (cadr (source-code source)))
1760 (define (**c-initialize-expr? source)
1761 (and (match **c-initialize-sym 2 source)
1762 (let ((code (source-code source)))
1763 (or (string? (source-code (cadr code)))
1764 (pt-syntax-error
1765 source
1766 "Argument to 'c-initialize' must be a string")))))
1768 (define (c-initialization-body source)
1769 (cadr (source-code source)))
1771 (define (**c-lambda-expr? source)
1772 (and (match **c-lambda-sym 4 source)
1773 (let ((code (source-code source)))
1774 (if (not (string? (source-code (cadddr code))))
1775 (pt-syntax-error
1776 source
1777 "Third argument to 'c-lambda' must be a string")
1778 (check-c-function-type (cadr code) (caddr code) #f)))))
1780 (define (**c-define-expr? source env)
1781 (and (match **c-define-sym -7 source)
1782 (proper-c-definition? source env)))
1784 (define (proper-c-definition? source env)
1785 (let* ((code (source-code source))
1786 (pattern-source (cadr code))
1787 (pattern (source-code pattern-source))
1788 (arg-typs-source (caddr code))
1789 (res-typ-source (cadddr code))
1790 (name-source (car (cddddr code)))
1791 (name (source-code name-source))
1792 (scope-source (cadr (cddddr code)))
1793 (scope (source-code scope-source)))
1794 (cond ((not (pair? pattern))
1795 (pt-syntax-error
1796 pattern-source
1797 "Ill-formed definition pattern"))
1798 ((not (bindable-var? (car pattern) env))
1799 (pt-syntax-error
1800 (car pattern)
1801 "Procedure name must be an identifier"))
1802 (else
1803 (and (check-c-function-type arg-typs-source res-typ-source #f)
1804 (cond ((not (string? name))
1805 (pt-syntax-error
1806 name-source
1807 "Fourth argument to 'c-define' must be a string"))
1808 ((not (valid-c-or-c++-function-id? name))
1809 (pt-syntax-error
1810 name-source
1811 "Ill-formed C function identifier"))
1812 ((not (string? scope))
1813 (pt-syntax-error
1814 scope-source
1815 "Fifth argument to 'c-define' must be a string"))
1816 (else
1817 #t)))))))
1819 (define (c-definition-name source)
1820 (let ((code (source-code source)))
1821 (car (source-code (cadr code)))))
1823 (define (c-definition-value source)
1824 (let ((code (source-code source))
1825 (loc (source-locat source)))
1826 (make-source
1827 (cons (make-source **lambda-sym loc)
1828 (cons (parms->source (cdr (source-code (cadr code))) loc)
1829 (cdr (cddddr code))))
1830 loc)))
1832 (define (c-definition-param-types source)
1833 (source-code (caddr (source-code source))))
1835 (define (c-definition-result-type source)
1836 (cadddr (source-code source)))
1838 (define (c-definition-proc-name source)
1839 (car (cddddr (source-code source))))
1841 (define (c-definition-scope source)
1842 (cadr (cddddr (source-code source))))
1844 (define (c-type-pt-syntax-error source err-source msg . args)
1845 (apply pt-syntax-error (cons (or err-source source) (cons msg args))))
1847 (define (check-c-function-type arg-typs-source res-typ-source err-source)
1848 (and (check-c-arg-types arg-typs-source err-source)
1849 (check-c-result-type res-typ-source err-source)))
1851 (define (check-c-arg-types arg-typs-source err-source)
1852 (let ((arg-typs (source-code arg-typs-source)))
1853 (if (not (proper-length arg-typs))
1854 (c-type-pt-syntax-error
1855 arg-typs-source
1856 err-source
1857 "Ill-terminated C function argument type list")
1858 (let loop ((lst arg-typs))
1859 (if (pair? lst)
1860 (and (check-c-type (car lst) err-source #f) ; void not allowed
1861 (loop (cdr lst)))
1862 #t)))))
1864 (define (check-c-result-type res-typ-source err-source)
1865 (check-c-type res-typ-source err-source #t)) ; allow all types
1867 (define (check-c-type typ-source err-source void-allowed?)
1869 (define (ill-formed-c-type)
1870 (c-type-pt-syntax-error typ-source err-source "Ill-formed C type"))
1872 (let ((typ (source-code typ-source)))
1873 (cond ((pair? typ)
1874 (let ((len (proper-length (cdr typ))))
1875 (if len
1876 (let ((head (source-code (car typ))))
1878 (define (check pointer? err-msg)
1879 (or (and (>= len 1)
1880 (<= len 3)
1881 (let* ((x-source (cadr typ))
1882 (x (source-code x-source)))
1883 (if pointer?
1884 (check-c-type
1885 x-source
1886 err-source
1887 #t) ; allow all types
1888 (and (string? x)
1889 (valid-c-or-c++-type-id? x))))
1890 (or (< len 2)
1891 (let ((tag (source-code (caddr typ))))
1892 (or (false-object? tag)
1893 (symbol-object? tag)
1894 (and (pair? tag)
1895 (proper-length tag)
1896 (every?
1897 (lambda (x)
1898 (symbol-object?
1899 (source-code x)))
1900 tag)))))
1901 (or (< len 3)
1902 (let ((id (source-code (cadddr typ))))
1903 (or (false-object? id)
1904 (and (string? id)
1905 (valid-c-or-c++-function-id? id))))))
1906 (c-type-pt-syntax-error
1907 typ-source
1908 err-source
1909 err-msg)))
1911 (define (check-function err-msg)
1912 (if (= len 2)
1913 (check-c-function-type
1914 (cadr typ)
1915 (caddr typ)
1916 err-source)
1917 (c-type-pt-syntax-error
1918 typ-source
1919 err-source
1920 err-msg)))
1922 (cond ((eq? head struct-sym)
1923 (check #f "Ill-formed C STRUCT type"))
1924 ((eq? head union-sym)
1925 (check #f "Ill-formed C UNION type"))
1926 ((eq? head type-sym)
1927 (check #f "Ill-formed C TYPE type"))
1928 ((eq? head pointer-sym)
1929 (check #t "Ill-formed C POINTER type"))
1930 ((eq? head nonnull-pointer-sym)
1931 (check #t "Ill-formed C NONNULL POINTER type"))
1932 ((eq? head function-sym)
1933 (check-function "Ill-formed C FUNCTION type"))
1934 ((eq? head nonnull-function-sym)
1935 (check-function "Ill-formed C NONNULL FUNCTION type"))
1936 (else
1937 (ill-formed-c-type))))
1939 (c-type-pt-syntax-error
1940 typ-source
1941 err-source
1942 "Ill-terminated C type"))))
1943 ((string? typ)
1944 (or (valid-c-or-c++-type-id? typ)
1945 (c-type-pt-syntax-error
1946 typ-source
1947 err-source
1948 "Ill-formed C type identifier")))
1949 ((symbol-object? typ)
1950 (if (eq? typ void-sym)
1951 (or void-allowed?
1952 (c-type-pt-syntax-error
1953 typ-source
1954 err-source
1955 "Ill-placed C VOID type"))
1956 (let ((x (assq typ c-interface-types)))
1957 (if x
1958 (let ((def (cdr x)))
1959 (case (vector-ref def 0)
1960 ((c-type)
1961 #t)
1962 (else
1963 (check-c-type
1964 (vector-ref def 1)
1965 typ-source
1966 void-allowed?))))
1967 (c-type-pt-syntax-error
1968 typ-source
1969 err-source
1970 "Undefined C type identifier:"
1971 typ)))))
1972 (else
1973 (ill-formed-c-type)))))
1975 (define (resolve-type typ-source)
1976 (let ((typ (source-code typ-source)))
1977 (if (symbol-object? typ)
1978 (let ((x (assq typ c-interface-types)))
1979 (if x
1980 (let ((def (cdr x)))
1981 (if (eq? (vector-ref def 0) 'alias)
1982 (resolve-type (vector-ref def 1))
1983 typ-source))
1984 typ-source))
1985 typ-source)))
1987 (define (void-type? typ-source)
1988 (eq? (source-code (resolve-type typ-source)) void-sym))
1990 (define (scmobj-type? typ-source)
1991 (eq? (source-code (resolve-type typ-source)) scheme-object-sym))
1993 (define (type-needs-cleanup? typ-source)
1994 (let ((typ (source-code typ-source)))
1995 (cond ((pair? typ)
1996 (let ((head (source-code (car typ))))
1997 (or (eq? head struct-sym)
1998 (eq? head union-sym)
1999 (eq? head type-sym)
2000 (eq? head function-sym)
2001 (eq? head nonnull-function-sym))))
2002 ((string? typ)
2003 #t)
2004 ((symbol-object? typ)
2005 (let ((x (assq typ c-interface-types)))
2006 (if x
2007 (let ((def (cdr x)))
2008 (case (vector-ref def 0)
2009 ((c-type)
2010 (vector-ref def 4))
2011 (else
2012 (type-needs-cleanup? (vector-ref def 1)))))
2013 #f)))
2014 (else
2015 #f))))
2017 (define (type-accessed-indirectly? typ-source)
2018 (let ((typ (source-code typ-source)))
2019 (cond ((pair? typ)
2020 (let ((head (source-code (car typ))))
2021 (cond ((eq? head struct-sym)
2022 (vector "STRUCT" (source-code (cadr typ))))
2023 ((eq? head union-sym)
2024 (vector "UNION" (source-code (cadr typ))))
2025 ((eq? head type-sym)
2026 (vector "TYPE" (source-code (cadr typ))))
2027 ((eq? head pointer-sym)
2028 '#("POINTER" #f))
2029 ((eq? head nonnull-pointer-sym)
2030 '#("NONNULLPOINTER" #f))
2031 ((eq? head function-sym)
2032 '#("FUNCTION" #f))
2033 ((eq? head nonnull-function-sym)
2034 '#("NONNULLFUNCTION" #f))
2035 (else
2036 #f))))
2037 ((string? typ)
2038 (vector "TYPE" typ))
2039 ((symbol-object? typ)
2040 (let ((x (assq typ c-interface-types)))
2041 (if x
2042 (let ((def (cdr x)))
2043 (case (vector-ref def 0)
2044 ((c-type)
2045 #f)
2046 (else
2047 (type-accessed-indirectly? (vector-ref def 1)))))
2048 #f)))
2049 (else
2050 #f))))
2052 (define (pt-c-lambda source env use)
2053 (let ((name
2054 (build-c-lambda
2055 (c-lambda-param-types source)
2056 (c-lambda-result-type source)
2057 (source-code (c-lambda-proc-name source)))))
2058 (new-ref source
2059 env
2060 (env-lookup-global-var env (string->symbol name)))))
2062 (define (c-lambda-param-types source)
2063 (source-code (cadr (source-code source))))
2065 (define (c-lambda-result-type source)
2066 (caddr (source-code source)))
2068 (define (c-lambda-proc-name source)
2069 (cadddr (source-code source)))
2071 (define (number-from-1 lst)
2072 (let loop ((i 1) (lst1 lst) (lst2 '()))
2073 (if (pair? lst1)
2074 (loop (+ i 1) (cdr lst1) (cons (cons (car lst1) i) lst2))
2075 (reverse lst2))))
2077 (define (c-type-converter to-scmobj? typ from to)
2079 (define (err)
2080 (compiler-internal-error "c-type-converter, unknown C type"))
2082 (define (convert kind name tag id)
2083 (let ((tag-str
2084 (if (false-object? tag)
2085 (string-append c-id-prefix "FAL")
2086 (let* ((tag-list (if (symbol-object? tag) (list tag) tag))
2087 (x (object-pos-in-list tag-list c-interface-objs)))
2088 (string-append
2089 c-id-prefix
2090 "C_OBJ_"
2091 (number->string
2092 (if x
2093 (- (- c-interface-obj-count x) 1)
2094 (let ((n c-interface-obj-count))
2095 (add-c-obj tag-list)
2096 n))))))))
2097 (if to-scmobj?
2099 (string-append
2100 (cond ((eq? kind pointer-sym)
2101 "POINTER_TO_SCMOBJ(")
2102 ((eq? kind nonnull-pointer-sym)
2103 "NONNULLPOINTER_TO_SCMOBJ(")
2104 (else
2105 (string-append
2106 (cond ((eq? kind struct-sym)
2107 "STRUCT_TO_SCMOBJ(")
2108 ((eq? kind union-sym)
2109 "UNION_TO_SCMOBJ(")
2110 (else
2111 "TYPE_TO_SCMOBJ("))
2112 name
2113 ",")))
2114 from "_voidstar," tag-str ","
2115 (if (false-object? id)
2116 (if (or (eq? kind pointer-sym)
2117 (eq? kind nonnull-pointer-sym))
2118 (string-append
2119 c-id-prefix
2120 "RELEASE_POINTER")
2121 (let* ((descr
2122 (cons kind name))
2123 (x
2124 (assoc descr c-interface-release-fns)))
2125 (if x
2126 (cdr x)
2127 (let* ((i
2128 c-interface-release-fn-count)
2129 (release-fn
2130 (string-append
2131 c-id-prefix
2132 "release_fn"
2133 (number->string i))))
2134 (set! c-interface-release-fn-count
2135 (+ i 1))
2136 (set! c-interface-release-fns
2137 (cons (cons descr release-fn)
2138 c-interface-release-fns))
2139 (add-c-decl
2140 (string-append
2141 c-id-prefix
2142 (cond ((eq? kind struct-sym)
2143 "DEF_RELEASE_FN_STRUCT(")
2144 ((eq? kind union-sym)
2145 "DEF_RELEASE_FN_UNION(")
2146 (else
2147 "DEF_RELEASE_FN_TYPE("))
2148 name
2149 ","
2150 release-fn
2151 ")"))
2152 release-fn))))
2153 id)
2154 "," to)
2156 (string-append
2157 (cond ((eq? kind pointer-sym)
2158 "SCMOBJ_TO_POINTER(")
2159 ((eq? kind nonnull-pointer-sym)
2160 "SCMOBJ_TO_NONNULLPOINTER(")
2161 (else
2162 (string-append
2163 (cond ((eq? kind struct-sym)
2164 "SCMOBJ_TO_STRUCT(")
2165 ((eq? kind union-sym)
2166 "SCMOBJ_TO_UNION(")
2167 (else
2168 "SCMOBJ_TO_TYPE("))
2169 name
2170 ",")))
2171 from "," to "_voidstar," tag-str))))
2173 (let ((t (source-code typ)))
2174 (cond ((pair? t)
2175 (let ((head (source-code (car t)))
2176 (len (length (cdr t))))
2177 (cond ((or (eq? head struct-sym)
2178 (eq? head union-sym)
2179 (eq? head type-sym)
2180 (eq? head pointer-sym)
2181 (eq? head nonnull-pointer-sym))
2182 (convert
2183 head
2184 (source-code (cadr t))
2185 (if (>= len 2)
2186 (source->expression (caddr t))
2187 (string->symbol (c-type-decl typ "")))
2188 (if (>= len 3)
2189 (source-code (cadddr t))
2190 false-object)))
2191 ((or (eq? head function-sym)
2192 (eq? head nonnull-function-sym))
2193 (if to-scmobj?
2194 (string-append
2195 (if (eq? head function-sym)
2196 "FUNCTION_TO_SCMOBJ("
2197 "NONNULLFUNCTION_TO_SCMOBJ(")
2198 from "_voidstar," to)
2199 (let ((converter
2200 (fn-param-converter typ)))
2201 (string-append
2202 (if (eq? head function-sym)
2203 "SCMOBJ_TO_FUNCTION("
2204 "SCMOBJ_TO_NONNULLFUNCTION(")
2205 from "," converter "," to "_voidstar"))))
2206 (else
2207 (err)))))
2208 ((string? t)
2209 (convert
2210 type-sym
2211 t
2212 false-object
2213 false-object))
2214 ((symbol-object? t)
2215 (let ((x (assq t c-interface-types)))
2216 (if x
2217 (let ((def (cdr x)))
2218 (case (vector-ref def 0)
2219 ((c-type)
2220 (if to-scmobj?
2221 (string-append
2222 (vector-ref def 2)
2223 "(" from "," to)
2224 (string-append
2225 (vector-ref def 3)
2226 "(" from "," to)))
2227 (else
2228 (c-type-converter
2229 to-scmobj?
2230 (vector-ref def 1)
2231 from
2232 to))))
2233 (err))))
2234 (else
2235 (err)))))
2237 (define nl-str (string #\newline))
2239 (define (c-preproc-define id val body)
2240 (string-append
2241 "#define " id " " val nl-str
2242 body
2243 "#undef " id nl-str))
2245 (define (c-preproc-define-default-empty id body)
2246 (string-append
2247 "#undef " id nl-str
2248 body
2249 "#ifndef " id nl-str
2250 "#define " id nl-str
2251 "#endif" nl-str))
2253 (define (c-result sfun? scheme-side?)
2254 (string-append
2255 c-id-prefix
2256 (if scheme-side?
2257 (if sfun? "SFUN_RESULT" "CFUN_RESULT")
2258 "result")))
2260 (define (c-argument scheme-side? numbered-typ)
2261 (let ((i (number->string (cdr numbered-typ))))
2262 (string-append
2263 c-id-prefix
2264 (if scheme-side? "ARG" "arg")
2265 i)))
2267 (define (c-declare-argument sfun? numbered-typ body)
2268 (let* ((c-id (c-argument #f numbered-typ))
2269 (scm-id (c-argument #t numbered-typ))
2270 (typ (car numbered-typ))
2271 (i (number->string (cdr numbered-typ)))
2272 (scmobj? (scmobj-type? typ))
2273 (indirect-access (type-accessed-indirectly? typ)))
2274 (string-append
2275 c-id-prefix
2276 (if scmobj?
2277 (if sfun? "BEGIN_SFUN_ARG_SCMOBJ(" "BEGIN_CFUN_ARG_SCMOBJ(")
2278 (if sfun? "BEGIN_SFUN_ARG(" "BEGIN_CFUN_ARG("))
2279 i
2280 (if scmobj?
2281 ""
2282 (string-append
2283 ","
2284 (if sfun?
2285 scm-id
2286 (if indirect-access
2287 (string-append "void* " c-id "_voidstar")
2288 (c-type-decl typ c-id)))))
2289 ")" nl-str
2290 (if indirect-access
2291 (if sfun?
2292 (if (vector-ref indirect-access 1)
2293 (let ((tail
2294 (string-append
2295 (vector-ref indirect-access 0)
2296 "("
2297 (vector-ref indirect-access 1)
2298 ","
2299 c-id "_voidstar,"
2300 c-id
2301 ")" nl-str)))
2302 (string-append
2303 c-id-prefix "BEGIN_SFUN_COPY_" tail
2304 body
2305 c-id-prefix "END_SFUN_COPY_" tail))
2306 (c-preproc-define
2307 (string-append c-id "_voidstar")
2308 (string-append c-id-prefix "SFUN_CAST(void*," c-id ")")
2309 body))
2310 (c-preproc-define
2311 c-id
2312 (string-append
2313 c-id-prefix
2314 (if (vector-ref indirect-access 1)
2315 (string-append
2316 "CFUN_CAST_AND_DEREF("
2317 (c-type-decl typ "*"))
2318 (string-append
2319 "CFUN_CAST("
2320 (c-type-decl typ "")))
2321 ","
2322 c-id "_voidstar)")
2323 body))
2324 body)
2325 c-id-prefix
2326 (if scmobj?
2327 (if sfun? "END_SFUN_ARG_SCMOBJ(" "END_CFUN_ARG_SCMOBJ(")
2328 (if sfun? "END_SFUN_ARG(" "END_CFUN_ARG("))
2329 i ")" nl-str)))
2331 (define (c-convert-representation sfun? to-scmobj? typ from to i body)
2332 (let ((tail
2333 (string-append
2334 (c-type-converter to-scmobj? typ from to)
2335 (if i (string-append "," i) "")
2336 ")" nl-str)))
2337 (string-append
2338 c-id-prefix (if sfun? "BEGIN_SFUN_" "BEGIN_CFUN_") tail
2339 body
2340 c-id-prefix (if sfun? "END_SFUN_" "END_CFUN_") tail)))
2342 (define (c-convert-argument sfun? numbered-typ body)
2343 (let* ((typ
2344 (car numbered-typ))
2345 (from
2346 (c-argument (not sfun?) numbered-typ))
2347 (to
2348 (c-argument sfun? numbered-typ))
2349 (i
2350 (number->string (cdr numbered-typ)))
2351 (decl
2352 (c-declare-argument
2353 sfun?
2354 numbered-typ
2355 (if (scmobj-type? typ)
2356 (c-preproc-define to from body)
2357 (c-convert-representation sfun? sfun? typ from to i body)))))
2358 (if sfun?
2359 decl
2360 (c-preproc-define
2361 from
2362 (string-append
2363 c-id-prefix
2364 "CFUN_ARG("
2365 i
2366 ")")
2367 decl))))
2369 (define (c-set-result sfun? result-typ)
2370 (cond ((void-type? result-typ)
2371 (string-append
2372 c-id-prefix
2373 (if sfun? "SFUN_SET_RESULT_VOID" "CFUN_SET_RESULT_VOID")
2374 nl-str))
2375 ((scmobj-type? result-typ)
2376 (string-append
2377 c-id-prefix
2378 (if sfun? "SFUN_SET_RESULT_SCMOBJ" "CFUN_SET_RESULT_SCMOBJ")
2379 nl-str))
2380 (else
2381 (c-convert-representation
2382 sfun?
2383 (not sfun?)
2384 result-typ
2385 (c-result sfun? sfun?)
2386 (c-result sfun? (not sfun?))
2387 #f
2388 (string-append
2389 c-id-prefix
2390 (if sfun? "SFUN_SET_RESULT" "CFUN_SET_RESULT")
2391 nl-str)))))
2393 (define (c-make-function sfun? param-typs result-typ make-body)
2394 (let ((cleanup?
2395 (not (every? (lambda (t) (not (type-needs-cleanup? t)))
2396 param-typs))))
2398 (define (convert-param-list)
2400 (define (scmobj-typ? numbered-typ)
2401 (scmobj-type? (car numbered-typ)))
2403 (define (not-scmobj-typ? numbered-typ)
2404 (not (scmobj-typ? numbered-typ)))
2406 (let ((numbered-param-typs (number-from-1 param-typs)))
2407 (let convert ((numbered-typs
2408 (append (keep scmobj-typ? numbered-param-typs)
2409 (keep not-scmobj-typ? numbered-param-typs))))
2410 (if (null? numbered-typs)
2411 (make-body (c-set-result sfun? result-typ) cleanup?)
2412 (c-convert-argument
2413 sfun?
2414 (car numbered-typs)
2415 (convert (cdr numbered-typs)))))))
2417 (c-preproc-define
2419 (string-append c-id-prefix "NARGS")
2421 (number->string (length param-typs))
2423 (if (void-type? result-typ)
2425 (string-append
2426 c-id-prefix
2427 (if sfun?
2428 (string-append
2429 "BEGIN_SFUN_VOID("
2430 sfun?
2431 ")")
2432 "BEGIN_CFUN_VOID")
2433 nl-str
2434 (convert-param-list)
2435 c-id-prefix
2436 (if sfun?
2437 "SFUN_ERROR_VOID"
2438 (if cleanup? "CFUN_ERROR_CLEANUP_VOID" "CFUN_ERROR_VOID"))
2439 nl-str
2440 (if sfun?
2441 (c-set-result sfun? result-typ)
2442 "")
2443 c-id-prefix
2444 (if sfun? "END_SFUN_VOID" "END_CFUN_VOID") nl-str)
2446 (let* ((c-id
2447 (c-result sfun? #f))
2448 (scmobj-result?
2449 (scmobj-type? result-typ))
2450 (indirect-access-result
2451 (type-accessed-indirectly? result-typ))
2452 (body
2453 (string-append
2454 c-id-prefix
2455 (if scmobj-result?
2456 (if sfun?
2457 (string-append
2458 "BEGIN_SFUN_SCMOBJ("
2459 sfun?
2460 ")")
2461 "BEGIN_CFUN_SCMOBJ")
2462 (string-append
2463 (if sfun?
2464 (string-append
2465 "BEGIN_SFUN("
2466 sfun?
2467 ",")
2468 "BEGIN_CFUN(")
2469 (if indirect-access-result
2470 (string-append "void* " c-id "_voidstar"
2471 (if sfun? " = 0" ""))
2472 (c-type-decl result-typ c-id))
2473 ")"))
2474 nl-str
2475 (convert-param-list)
2476 c-id-prefix
2477 (if scmobj-result?
2478 (if sfun?
2479 "SFUN_ERROR_SCMOBJ"
2480 (if cleanup? "CFUN_ERROR_CLEANUP_SCMOBJ" "CFUN_ERROR_SCMOBJ"))
2481 (if sfun?
2482 "SFUN_ERROR"
2483 (if cleanup? "CFUN_ERROR_CLEANUP" "CFUN_ERROR")))
2484 nl-str
2485 (if sfun?
2486 (c-set-result sfun? result-typ)
2487 "")
2488 c-id-prefix
2489 (if scmobj-result?
2490 (if sfun? "END_SFUN_SCMOBJ" "END_CFUN_SCMOBJ")
2491 (if sfun? "END_SFUN" "END_CFUN"))
2492 nl-str
2493 (if sfun?
2494 (string-append "return " c-id ";" nl-str)
2495 ""))))
2496 (if indirect-access-result
2497 (c-preproc-define
2498 c-id
2499 (string-append
2500 c-id-prefix
2501 (if (vector-ref indirect-access-result 1)
2502 (string-append
2503 (if sfun? "SFUN_CAST_AND_DEREF(" "CFUN_CAST_AND_DEREF(")
2504 (c-type-decl result-typ "*"))
2505 (string-append
2506 (if sfun? "SFUN_CAST(" "CFUN_CAST(")
2507 (c-type-decl result-typ "")))
2508 ","
2509 c-id "_voidstar)")
2510 body)
2511 body))))))
2513 (define (comma-separated strs)
2514 (if (null? strs)
2515 ""
2516 (string-append
2517 (car strs)
2518 (apply string-append
2519 (map (lambda (s) (string-append "," s)) (cdr strs))))))
2521 (define (c-type-decl typ inner)
2523 (define (err)
2524 (compiler-internal-error "c-type-decl, unknown C type"))
2526 (define (prefix-inner str)
2527 (if (and (> (string-length inner) 0)
2528 (c-id-subsequent? (string-ref inner 0)))
2529 (string-append str " " inner)
2530 (string-append str inner)))
2532 (let ((t (source-code typ)))
2533 (cond ((pair? t)
2534 (let ((head (source-code (car t))))
2535 (cond ((eq? head struct-sym)
2536 (prefix-inner
2537 (string-append "struct " (source-code (cadr t)))))
2538 ((eq? head union-sym)
2539 (prefix-inner
2540 (string-append "union " (source-code (cadr t)))))
2541 ((eq? head type-sym)
2542 (prefix-inner
2543 (source-code (cadr t))))
2544 ((or (eq? head pointer-sym)
2545 (eq? head nonnull-pointer-sym))
2546 (c-type-decl (cadr t)
2547 (string-append "*" inner)))
2548 ((or (eq? head function-sym)
2549 (eq? head nonnull-function-sym))
2550 (c-type-decl (caddr t)
2551 (string-append
2552 "(*" inner ") "
2553 (c-param-list-with-types
2554 (source-code (cadr t))))))
2555 (else
2556 (err)))))
2557 ((string? t)
2558 (prefix-inner t))
2559 ((symbol-object? t)
2560 (let ((x (assq t c-interface-types)))
2561 (if x
2562 (let ((def (cdr x)))
2563 (case (vector-ref def 0)
2564 ((c-type)
2565 (prefix-inner (vector-ref def 1)))
2566 (else
2567 (c-type-decl (vector-ref def 1) inner))))
2568 (err))))
2569 (else
2570 (err)))))
2572 (define (c-param-list-with-types typs)
2573 (if (null? typs)
2574 (string-append c-id-prefix "PVOID")
2575 (string-append
2576 c-id-prefix
2577 "P(("
2578 (comma-separated (map (lambda (typ) (c-type-decl typ "")) typs))
2579 "),())")))
2581 (define (c-param-id numbered-typ)
2582 (c-argument #f numbered-typ))
2584 (define (c-param-list-with-ids numbered-typs)
2585 (if (null? numbered-typs)
2586 (string-append c-id-prefix "PVOID")
2587 (string-append
2588 c-id-prefix
2589 "P(("
2590 (comma-separated
2591 (map (lambda (t) (c-type-decl (car t) (c-param-id t)))
2592 numbered-typs))
2593 "),("
2594 (comma-separated (map c-param-id numbered-typs))
2595 ")"
2596 (apply string-append
2597 (map (lambda (t)
2598 (string-append
2599 nl-str
2600 (c-type-decl (car t) (c-param-id t))
2601 ";"))
2602 numbered-typs))
2603 ")")))
2605 (define (c-function-decl param-typs result-typ id scope body)
2606 (let ((numbered-typs (number-from-1 param-typs)))
2607 (let ((function-decl
2608 (c-type-decl result-typ
2609 (string-append
2610 id
2611 " "
2612 (if body
2613 (c-param-list-with-ids numbered-typs)
2614 (c-param-list-with-types param-typs))))))
2615 (if body
2616 (string-append
2617 scope " "
2618 function-decl nl-str
2619 "{" nl-str body "}" nl-str)
2620 (string-append
2621 function-decl ";" nl-str)))))
2623 (define (c-function param-typs result-typ proc-name c-defined? scope)
2624 (let ((proc-val
2625 (if c-defined?
2626 (string-append
2627 c-id-prefix "MLBL(" c-id-prefix "C_LBL_" proc-name ")")
2628 (string-append
2629 c-id-prefix "FAL"))))
2631 (define (make-body set-result-code cleanup?)
2632 (string-append
2633 c-id-prefix "BEGIN_SFUN_BODY" nl-str
2634 (let convert ((numbered-typs (number-from-1 param-typs)))
2635 (if (null? numbered-typs)
2636 (string-append
2637 c-id-prefix
2638 (cond ((void-type? result-typ)
2639 "SFUN_CALL_VOID")
2640 ((scmobj-type? result-typ)
2641 "SFUN_CALL_SCMOBJ")
2642 (else
2643 "SFUN_CALL"))
2644 nl-str)
2645 (let ((numbered-typ (car numbered-typs)))
2646 (string-append
2647 c-id-prefix
2648 "SFUN_ARG("
2649 (number->string (cdr numbered-typ))
2650 ","
2651 (c-argument #t numbered-typ)
2652 ")" nl-str
2653 (convert (cdr numbered-typs))))))
2654 set-result-code
2655 c-id-prefix "END_SFUN_BODY" nl-str))
2657 (add-c-decl
2658 (c-function-decl param-typs
2659 result-typ
2660 proc-name
2661 scope
2662 (c-make-function proc-val
2663 param-typs
2664 result-typ
2665 make-body)))))
2667 (define (fn-param-converter typ)
2668 (let ((function-c-type (c-type-decl typ "")))
2669 (cond ((assoc function-c-type c-interface-converters)
2670 =>
2671 cdr)
2672 (else
2673 (let* ((t
2674 (source-code typ))
2675 (param-typs
2676 (source-code (cadr t)))
2677 (result-typ
2678 (caddr t))
2679 (i
2680 c-interface-converter-count)
2681 (converter
2682 (string-append
2683 c-id-prefix
2684 "converter"
2685 (number->string i))))
2686 (set! c-interface-converter-count
2687 (+ i 1))
2688 (set! c-interface-converters
2689 (cons (cons function-c-type converter)
2690 c-interface-converters))
2691 (c-function
2692 param-typs
2693 result-typ
2694 converter
2695 #f
2696 (string-append c-id-prefix "LOCAL"))
2697 converter)))))
2699 (define (build-c-define param-typs result-typ proc-name scope)
2700 (c-function param-typs result-typ proc-name #t scope))
2702 (define (strip-param-typs param-typs)
2703 param-typs);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2705 (define (build-c-lambda param-typs result-typ proc-name)
2706 (let* ((index
2707 (number->string c-interface-proc-count))
2708 (scheme-name
2709 (string-append module-prefix c-interface-module-name "#" index))
2710 (c-name
2711 (string-append c-id-prefix (scheme-id->c-id scheme-name)))
2712 (arity
2713 (length param-typs))
2714 (stripped-param-typs
2715 (strip-param-typs param-typs)))
2717 (define (make-body set-result-code cleanup?)
2718 (string-append
2719 c-id-prefix
2720 (if cleanup? "BEGIN_CFUN_BODY_CLEANUP" "BEGIN_CFUN_BODY")
2721 nl-str
2722 (c-preproc-define-default-empty
2723 (string-append c-id-prefix "AT_END")
2724 (string-append
2725 (if (valid-c-or-c++-function-id? proc-name)
2726 (let ((c-id
2727 (c-result #f #f))
2728 (indirect-access-result
2729 (type-accessed-indirectly? result-typ))
2730 (call
2731 (string-append
2732 proc-name "("
2733 (comma-separated
2734 (map c-param-id (number-from-1 stripped-param-typs)))
2735 ")")))
2736 (cond ((void-type? result-typ)
2737 (string-append
2738 c-id-prefix
2739 "CFUN_CALL_VOID("
2740 call
2741 ")"))
2742 (indirect-access-result
2743 (if (vector-ref indirect-access-result 1)
2744 (string-append
2745 c-id-prefix
2746 "CFUN_CALL_"
2747 (vector-ref indirect-access-result 0)
2748 "("
2749 (vector-ref indirect-access-result 1)
2750 ","
2751 c-id "_voidstar,"
2752 call
2753 ")")
2754 (string-append
2755 c-id-prefix
2756 "CFUN_CALL_"
2757 (vector-ref indirect-access-result 0)
2758 "("
2759 c-id "_voidstar,"
2760 call
2761 ")")))
2762 (else
2763 (string-append
2764 c-id-prefix
2765 "CFUN_CALL("
2766 c-id ","
2767 call
2768 ")"))))
2769 proc-name)
2770 nl-str))
2771 set-result-code
2772 c-id-prefix
2773 (if cleanup? "END_CFUN_BODY_CLEANUP" "END_CFUN_BODY")
2774 nl-str))
2776 (add-c-proc
2777 (make-c-proc scheme-name
2778 c-name
2779 arity
2780 (c-make-function #f
2781 stripped-param-typs
2782 result-typ
2783 make-body)))
2784 scheme-name))
2786 (define (scheme-id->c-id s)
2787 (let loop1 ((i (- (string-length s) 1)) (lst '()))
2788 (if (>= i 0)
2789 (let ((c (string-ref s i)))
2790 (cond ((char=? c #\_)
2791 (loop1 (- i 1) (cons c (cons c lst))))
2792 ((c-id-subsequent? c)
2793 (loop1 (- i 1) (cons c lst)))
2794 (else
2795 (let ((n (character->unicode c)))
2796 (if (= n 0)
2797 (loop1 (- i 1) (cons #\_ (cons #\0 (cons #\_ lst))))
2798 (let loop2 ((n n) (lst (cons #\_ lst)))
2799 (if (> n 0)
2800 (loop2 (quotient n 16)
2801 (cons (string-ref "0123456789abcdef"
2802 (modulo n 16))
2803 lst))
2804 (loop1 (- i 1) (cons #\_ lst)))))))))
2805 (list->str lst))))
2807 (define (c-id-initial? c) ; c is one of #\A..#\Z, #\a..#\z, #\_
2808 (let ((n (character->unicode c)))
2809 (or (and (>= n 65) (<= n 90))
2810 (and (>= n 97) (<= n 122))
2811 (= n 95))))
2813 (define (c-id-subsequent? c) ; c is one of #\A..#\Z, #\a..#\z, #\_, #\0..#\9
2814 (let ((n (character->unicode c)))
2815 (or (and (>= n 65) (<= n 90))
2816 (and (>= n 97) (<= n 122))
2817 (= n 95)
2818 (and (>= n 48) (<= n 57)))))
2820 (define (valid-c-id? id type?)
2821 (let ((n (string-length id)))
2822 (and (> n 0)
2823 (c-id-initial? (string-ref id 0))
2824 (let loop ((i 1) (depth 0))
2825 (if (< i n)
2826 (let ((c (string-ref id i)))
2827 (cond ((and (< (+ i 2) n)
2828 (char=? #\: c)
2829 (char=? #\: (string-ref id (+ i 1)))
2830 (c-id-initial? (string-ref id (+ i 2))))
2831 (loop (+ i 3) depth))
2832 ((and type?
2833 (< (+ i 1) n)
2834 (char=? #\< c)
2835 (c-id-initial? (string-ref id (+ i 1))))
2836 (loop (+ i 2) (+ depth 1)))
2837 ((and (< (+ i 1) n)
2838 (char=? #\, c)
2839 (c-id-initial? (string-ref id (+ i 1)))
2840 (> depth 0))
2841 (loop (+ i 2) depth))
2842 ((and (char=? #\> c)
2843 (> depth 0))
2844 (loop (+ i 1) (- depth 1)))
2845 ((c-id-subsequent? c)
2846 (loop (+ i 1) depth))
2847 (else
2848 #f)))
2849 (= depth 0))))))
2851 (define (valid-c-or-c++-function-id? id)
2852 (valid-c-id? id #f))
2854 (define (valid-c-or-c++-type-id? id)
2855 (valid-c-id? id #t))
2857 ;;;============================================================================