1 ;;;============================================================================
3 ;;; File: "_ptree2.scm"
5 ;;; Copyright (c) 1994-2011 by Marc Feeley, All Rights Reserved.
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")
21 ;;;----------------------------------------------------------------------------
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)))
35 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
37 ;; (delete-ptree ptree) removes parse tree 'ptree' from program and updates
38 ;; references and assignments to variables.
40 (define (delete-ptree ptree)
43 (let ((var (ref-var ptree)))
44 (var-refs-set! var (ptset-remove (var-refs var) ptree))))
47 (let ((var (set-var ptree)))
48 (var-sets-set! var (ptset-remove (var-sets var) 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)
65 (define (cp ptree substs)
67 (define (rename-var var)
68 (let ((x (assq var substs)))
72 (new-cst (node-source ptree) (node-env ptree)
76 (let ((var (rename-var (ref-var ptree))))
77 (new-ref (node-source ptree) (node-env ptree)
81 (let ((var (rename-var (set-var ptree))))
82 (new-set (node-source ptree) (node-env ptree)
84 (cp (set-val ptree) substs))))
86 ((def? ptree) ; guaranteed to be a toplevel definition
87 (new-def (node-source ptree) (node-env ptree)
89 (cp (def-val ptree) substs)))
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)))
98 (new-conj (node-source ptree) (node-env ptree)
99 (cp (conj-pre ptree) substs)
100 (cp (conj-alt ptree) substs)))
103 (new-disj (node-source ptree) (node-env ptree)
104 (cp (disj-pre ptree) substs)
105 (cp (disj-alt ptree) substs)))
108 (let* ((parms (prc-parms ptree))
109 (vars (clone-vars parms)))
110 (new-prc (node-source ptree) (node-env ptree)
118 (append (pair-up parms vars) substs)))))
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)))
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))))))
139 (new-fut (node-source ptree) (node-env ptree)
140 (cp (fut-val ptree) substs)))
143 (compiler-internal-error "cp, unknown parse tree node type"))))
145 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
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)
160 (cond ((or (cst? ptree)
162 (def? ptree) ; guaranteed to be a toplevel definition
168 (node-children-set! ptree
170 (node-children ptree)))
174 (let ((proc (global-proc-obj ptree)))
177 (new-cst (node-source ptree) (node-env ptree)
187 (map epc (app-args ptree)))
190 (let ((var (ref-var oper)))
195 (target.prim-info name))
197 (specialize-proc proc args (node-env oper)))
203 (define (generate-spec-call vars)
204 (new-call source (add-not-inline-primitives env)
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)
213 (gen-var-refs source env vars)))
215 (define (generate-run-time-binding-test gen-body)
216 (let ((vars (gen-temp-vars source args)))
220 (gen-eq-proc source env
227 (generate-original-call vars)))))
230 (inline-primitive? name env)
231 (or ((proc-obj-inlinable? spec) env)
232 ((proc-obj-expandable? spec) env)))
234 (standard-proc-obj proc
238 (run-time-binding? name
241 (if ((proc-obj-inlinable? spec) env)
246 (generate-run-time-binding-test
253 ((proc-obj-expand spec)
258 generate-original-call
263 (gen-eq-proc source env
271 (not (eq? proc spec)))
272 (generate-run-time-binding-test
276 (gen-var-refs source env vars))))
290 (proc-obj? (cst-val oper)))
294 (specialize-proc proc args (node-env oper)))
301 (inline-primitive? (proc-obj-name spec) env)
302 ((proc-obj-expandable? spec) env)
303 ((proc-obj-expand spec)
310 (add-not-inline-primitives env)
313 (gen-var-refs source env vars)))
320 (node-children-set! ptree
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))
336 (gen-disj-multi source env (cdr nodes)))
339 (define (gen-uniform-type-checks source env vars type-check tail)
341 (define (loop result lst)
343 (loop (new-conj source env
344 (type-check (car lst))
352 (loop (type-check (car vars)) (cdr vars)))
356 (define (gen-temp-vars source args)
357 (let loop ((args args) (rev-vars '()))
361 (cons (new-temp-variable source 'temp)
364 (define (gen-var-refs source env vars)
370 (define (gen-call-prim-vars source env prim vars)
371 (gen-call-prim source env
373 (gen-var-refs source env vars)))
375 (define (gen-call-prim source env prim args)
376 (new-call source (add-not-safe env)
378 (target.prim-info prim))
381 (define (gen-eq-proc source env arg proc)
382 (gen-call-prim source env
389 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
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:
404 ;; are added to create and access the boxes.
406 (define (assignment-convert lst)
407 (map (lambda (ptree) (ac ptree '()))
410 (define (ac ptree mut)
416 (let ((var (ref-var ptree)))
419 (let ((x (assq var mut)))
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)
425 (list (new-ref source (node-env ptree) (cdr x)))))
429 (let ((var (set-var ptree))
430 (source (node-source ptree))
431 (val (ac (set-val ptree) mut)))
434 (var-sets-set! var (ptset-remove (var-sets var) ptree))
435 (new-set source (node-env ptree)
438 (gen-call-prim source (node-env ptree)
440 (list (new-ref source (node-env ptree) (cdr (assq var mut)))
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)
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)))
458 (new-conj (node-source ptree) (node-env ptree)
459 (ac (conj-pre ptree) mut)
460 (ac (conj-alt ptree) mut)))
463 (new-disj (node-source ptree) (node-env ptree)
464 (ac (disj-pre ptree) mut)
465 (ac (disj-alt ptree) mut)))
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)))
477 (new-call (node-source ptree) (node-env ptree)
479 (map (lambda (x) (ac x mut)) args)))))
482 (new-fut (node-source ptree) (node-env ptree)
483 (ac (fut-val ptree) mut)))
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)))
495 (for-each (lambda (var) (var-boxed?-set! var #t))
498 (new-prc (node-source ptree) (node-env ptree)
509 (gen-call-prim (var-source var) (node-env ptree)
511 (list (new-ref (var-source var)
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)))
530 (for-each (lambda (var) (var-boxed?-set! var #t))
537 (new-body (ac (prc-body proc) mut)))
540 (new-let ptree proc new-vars new-vals new-body)
545 (if (memq var mut-parms)
547 (let ((src (node-source val))
549 (var* (cdr (assq var mut))))
551 (if (varset-member? var vals-fv)
556 (cons (gen-call-prim src env
558 (list (new-cst src env void-object)))
561 (gen-call-prim src env
563 (list (new-ref src env var*)
570 (cons (gen-call-prim src env
579 (cons (ac val mut) new-vals)
582 (define (ac-mutables lst)
585 (define (clone-vars vars)
588 (make-var (var-name var)
593 (var-boxed?-set! cloned-var (var-boxed? var))
597 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
602 ;; (beta-reduce ptrees) takes a list of parse-trees and transforms
603 ;; each parse-tree with the following transformations:
605 ;; - constant propagation
606 ;; - copy propagation
607 ;; - useless variable elimination
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))
618 (loop (varset-adjoin set (car lst)) (cdr lst))
621 (define (pass1) ; transform definitions in dependency order
625 (vars-with-duplicates->varset (map def-var (reverse defs))))
633 (free-variables (def-val def))))
635 (ptset->list (var-sets var)))))))
636 (varset->list defined-vars)))
639 (transitive-closure depgraph))))
648 (list (br (def-val def) '() 'need #f))))
649 (keep def? (ptset->list (var-sets var)))))
650 (varset->list vars)))
653 (define (pass2) ; transform non-definitions from top to bottom
654 (let loop ((lst1 ptrees) (lst2 '()))
656 (let ((ptree (car lst1)))
657 (cond ((not (core? (node-env ptree)))
659 (loop (cdr lst1) lst2))
661 (loop (cdr lst1) (cons ptree lst2)))
663 (loop (cdr lst1) (cons (br ptree
674 (define (br ptree substs reason expansion-limit)
677 (new-cst (node-source ptree) (node-env 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)))
687 (new-ref (node-source ptree) (node-env ptree)
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)
699 (let ((pre (br (tst-pre ptree) substs 'pred expansion-limit)))
701 (if (false-object? (cst-val pre))
704 (delete-ptree (tst-con ptree))
705 (br (tst-alt ptree) substs reason expansion-limit))
708 (delete-ptree (tst-alt ptree))
709 (br (tst-con ptree) substs reason expansion-limit)))
710 (new-tst (node-source ptree) (node-env ptree)
712 (br (tst-con ptree) substs reason expansion-limit)
713 (br (tst-alt ptree) substs reason expansion-limit)))))
716 (let ((pre (br (conj-pre ptree) substs reason expansion-limit)))
718 (if (false-object? (cst-val pre))
720 (delete-ptree (conj-alt ptree))
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)
734 ; (and X #f) => (begin X #f)
735 ; this transform should be generalized
736 (new-seq (node-source ptree) (node-env ptree)
740 (not (false-object? (cst-val alt)))
742 ; (if (and X non-#f) ...) => (if X ...)
746 (new-conj (node-source ptree) (node-env ptree)
751 (let ((pre (br (disj-pre ptree) substs reason expansion-limit)))
753 (if (false-object? (cst-val pre))
756 (br (disj-alt ptree) substs reason expansion-limit))
758 (delete-ptree (disj-alt ptree))
760 (let ((alt (br (disj-alt ptree) substs reason expansion-limit)))
762 (false-object? (cst-val alt)))
767 (new-disj (node-source ptree) (node-env ptree)
772 (new-prc (node-source ptree) (node-env ptree)
779 (br (prc-body ptree) substs 'need expansion-limit)))
782 (br-let ptree substs reason expansion-limit))
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))))
795 (new-fut (node-source ptree) (node-env ptree)
796 (br (fut-val ptree) substs 'need expansion-limit)))
799 (compiler-internal-error "br, unknown parse tree node type"))))
801 (define (var-subst var substs)
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))
809 (var-subst var (cdr substs))))))
811 (define (var-to-val var substs)
813 (global-single-def var)
814 (let ((x (assq var substs)))
817 (define (br-let? 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))))
831 (or (bound? (ref-var body))
832 (global-singly-bound? body))))))
834 ;; let-floating transformation when the code is of the
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)
848 (new-call (node-source ptree) (node-env ptree)
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)
872 (br-extend-substs vars vals substs))
874 (map (lambda (x) (br x new-substs 'need expansion-limit)) vals))
876 (br-extend-substs vars br-vals substs))
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
889 (if (varset-equal? reachable-vars old-reachable-vars)
897 (bound-free-variables (var->val var))))
899 (varset-difference reachable-vars
900 old-reachable-vars)))))))))
902 ; remove useless bindings
904 (let ((reachable-vars
907 (cons (bound-free-variables new-body)
908 (map (lambda (br-val)
910 (varset-empty) ; reachable only if called
911 (bound-free-variables br-val)))
925 (if (and (not (varset-member? var reachable-vars))
930 (delete-ptree br-val)
938 (cons br-val new-vals)))))))))
940 (define (br-extend-substs vars vals substs)
948 (cond ((or (cst? val)
950 (or (bound? (ref-var val))
951 (global-singly-bound? val)))
953 (ptset-every? oper-pos? (var-refs var))))
956 (cons (cons var val) new-substs)))
962 (define (br-app-inline ptree br-oper args substs reason expansion-limit)
964 ; invariant: (or (cst? br-oper) (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)))
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
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.
999 (- (if expansion-limit
1000 (car expansion-limit)
1001 (quotient (* (inlining-limit (node-env ptree))
1005 (and (>= new-limit 0)
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))
1017 (map (lambda (arg) (br arg substs 'need expansion-limit)) args))
1019 (and (constant-fold? (node-env ptree))
1020 (specialize-app br-oper br-args (node-env ptree))))
1023 (nb-args-conforms? (length args) (proc-obj-call-pat proc))
1024 (proc-obj-simplify proc)))
1027 (simp ptree br-args))))
1028 (if simplified-ptree
1030 (delete-ptree br-oper)
1031 (for-each delete-ptree br-args)
1033 (new-call (node-source ptree) (node-env ptree)
1037 (define (ptree-size ptree)
1038 (let loop ((lst (node-children ptree)) (n 1))
1041 (loop (cdr lst) (+ n (ptree-size (car lst)))))))
1043 (define (side-effects-impossible? ptree)
1051 ((set? ptree) ; variable guaranteed to be a global variable
1055 (and (side-effects-impossible? (tst-pre ptree))
1056 (side-effects-impossible? (tst-con ptree))
1057 (side-effects-impossible? (tst-alt ptree))))
1060 (and (side-effects-impossible? (conj-pre ptree))
1061 (side-effects-impossible? (conj-alt ptree))))
1064 (and (side-effects-impossible? (disj-pre ptree))
1065 (side-effects-impossible? (disj-alt 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)))
1080 (not (proc-obj-side-effects? proc))))))))
1083 (side-effects-impossible? (fut-val ptree)))
1086 (compiler-internal-error "side-effects-impossible?, unknown parse tree node type"))))
1088 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
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) '()))
1108 (define (ll! ptree cst-procs env)
1110 (define (new-env env vars)
1113 (let ((var (car l)))
1114 (cons (cons var (cons (ptset-size (var-refs var)) i))
1115 (loop (+ i 1) (cdr l))))
1117 (loop (length env) vars))
1119 (cond ((or (cst? ptree)
1122 (def? ptree) ; guaranteed to be a toplevel definition
1127 (for-each (lambda (child) (ll! child cst-procs env))
1128 (node-children ptree)))
1131 (ll! (prc-body ptree) cst-procs (new-env env (prc-parms 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))))
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))
1154 (if (proc-obj? proc)
1156 (proc-obj-lift-pat proc))
1158 (modulo (quotient lift-pat 1000) 10))
1160 (modulo (quotient lift-pat 100) 10))
1161 (nb-req-and-opt-parms
1162 (modulo (quotient lift-pat 10) 10))
1164 (modulo lift-pat 10))
1169 (if (and (< 0 receiver-arg-pos)
1170 (<= min-nb-args nb-args))
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)))
1182 (ll-lifted-vars (bound-free-variables receiver)
1185 (if (and (not (null? vars))
1186 (<= (+ (length vars) (- nb-args min-nb-args))
1188 (let ((cloned-vars (clone-vars vars)))
1192 (define (new-ref* var)
1193 (new-ref (var-source var) (node-env ptree) var))
1198 (append (take args min-nb-args)
1200 (drop args min-nb-args))))
1202 ;; modify receiver procedure
1206 (append (take (prc-parms receiver)
1207 nb-req-and-opt-parms)
1209 (drop (prc-parms receiver)
1210 nb-req-and-opt-parms)))
1211 (for-each (lambda (x) (var-bound-set! x receiver))
1213 (node-fv-invalidate! receiver)
1214 (for-each (lambda (x y) (var-clone-set! x y))
1217 (ll-rename! receiver)
1218 (for-each (lambda (x) (var-clone-set! x #f))
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
1232 (let ((val (var->val var)))
1234 (lambda-lift? (node-env val))
1235 (ptset-every? oper-pos? (var-refs var)))))
1237 (let* ((cst-proc-vars
1238 (list->varset cst-proc-vars-list))
1239 (non-cst-proc-vars-list
1241 (let ((val (var->val var)))
1243 (not (varset-member? var cst-proc-vars)))))
1246 (list->varset non-cst-proc-vars-list))
1247 (cst-proc-vars-list*
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*))
1256 (loop cst-proc-vars-list*)))))
1258 (define (transitively-closed-bound-free-variables vars)
1261 (cons var (bound-free-variables (var->val var))))
1264 (let ((changed? #f))
1265 (for-each (lambda (var-tcbfv)
1266 (let ((tcbfv (cdr var-tcbfv)))
1267 (let loop2 ((l (varset->list tcbfv))
1270 (if (not (= (varset-size fv)
1271 (varset-size tcbfv)))
1273 (set-cdr! var-tcbfv fv)
1274 (set! changed? #t)))
1275 (let ((x (assq (car l) tcbfv-map)))
1278 (varset-union fv (cdr x))
1286 (transitively-closed-bound-free-variables
1287 (liftable-proc-vars vars)))
1289 (map car tcbfv-map))
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)
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)
1335 (sort-list (map (lambda (var) (assq var env)) vars)
1337 ;;;; (if (= (cadr x) (cadr y))
1338 ;;;; (< (cddr x) (cddr y))
1339 ;;;; (< (cadr x) (cadr y)))
1340 (< (cddr x) (cddr y))))))
1343 (varset->list (varset-difference bfv cst-procs))))
1345 (define (ll-rename! ptree)
1348 (let* ((var (ref-var ptree))
1349 (x (var-clone var)))
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 ;;;----------------------------------------------------------------------------
1366 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
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)
1377 (let ((val (cst-val ptree)))
1381 (se-var->id (ref-var ptree) env))
1385 (se-var->id (set-var ptree) env)
1386 (se (set-val ptree) env num)))
1390 (se-var->id (def-var ptree) env)
1391 (se (def-val ptree) env num)))
1394 (list if-sym (se (tst-pre ptree) env num)
1395 (se (tst-con ptree) env num)
1396 (se (tst-alt ptree) env num)))
1399 (list and-sym (se (conj-pre ptree) env num)
1400 (se (conj-alt ptree) env num)))
1403 (list or-sym (se (disj-pre ptree) env num)
1404 (se (disj-alt ptree) env num)))
1407 (let ((new-env (se-rename ptree env num)))
1409 (se-parameters (prc-parms ptree)
1415 (se (prc-body ptree) new-env num))))
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)))
1425 (if (varset-intersects?
1426 (list->varset (prc-parms oper))
1427 (varset-union-multi (map bound-free-variables args)))
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)))))
1435 (list future-sym (se (fut-val ptree) env num)))
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)
1447 (if use-actual-primitives-in-expression?
1448 (eval (string->symbol (proc-obj-name val)))
1449 (list '*primitive* (proc-obj-name val)))
1452 (define (se-var->id var env)
1453 (let ((id (let ((x (assq var env)))
1454 (if x (cdr x) (var-name var)))))
1457 ;; (string-append (symbol->string id)
1459 ;; (number->string (##object->serial-number var))))
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)
1469 (let ((parm (se-var->id (car parms) env)))
1470 (cons parm (se-required (cdr parms) (- n 1))))))
1472 (define (se-opts parms)
1474 (se-rest-and-keys parms)
1475 (cons optional-object
1476 (let loop ((parms parms) (opts 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?
1488 (cons rest-object (cons parm '()))))
1491 (let ((parm (se-var->id (car (last-pair parms)) env)))
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)
1503 (let loop ((parms parms) (keys keys))
1506 (let ((parm (se-var->id (car parms) env)))
1507 (cons (list parm (se-constant (cdr (car keys))))
1508 (loop (cdr parms) (cdr keys)))))))))
1513 (if keys (length keys) 0)
1516 (define (se-bindings vars vals env num)
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)
1526 (varset->list (free-variables (prc-body proc))))
1528 (map var-name parms))
1530 (map var-name free-vars))
1532 (append p-names fv-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))
1542 (let ((x (car lst)))
1543 (if (and (not (= i j))
1545 (eq? x (var-name var)))
1547 (loop (cdr lst) (+ j 1))))))))
1549 (define (rename vars i)
1552 (let* ((var (car vars))
1553 (id (var-name var)))
1555 (if (conflict? var i)
1557 (set-car! num (+ (car num) 1))
1559 (string-append (symbol->string id)
1561 (number->string (car num)))))
1563 (rename (cdr vars) (+ i 1))))))
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 '())
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)
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))
1624 (define (add-c-decl declaration-string)
1625 (set! c-interface-decls
1626 (cons declaration-string c-interface-decls))
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))
1635 (define (add-c-init initialization-code-string)
1636 (set! c-interface-inits
1637 (cons initialization-code-string c-interface-inits))
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))
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))
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))
1685 "C type's name must be an identifier"))
1686 ((assq name c-interface-types)
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
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))
1705 "Second argument to 'c-define-type' must be a string"))
1706 ((not (string? ctos))
1709 "Third argument to 'c-define-type' must be a string"))
1710 ((not (valid-c-or-c++-function-id? ctos))
1713 "Ill-formed C function identifier"))
1714 ((not (string? stoc))
1717 "Fourth argument to 'c-define-type' must be a string"))
1718 ((not (valid-c-or-c++-function-id? stoc))
1721 "Ill-formed C function identifier"))
1722 ((not (or (false-object? cleanup)
1726 "Fifth argument to 'c-define-type' must be a boolean"))
1730 (define (c-type-definition-name source)
1731 (let ((code (source-code source)))
1734 (define (c-type-definition-type source)
1735 (let ((code (source-code source)))
1736 (if (= (length code) 3)
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)))
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)))
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))))
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))
1793 "Ill-formed definition pattern"))
1794 ((not (bindable-var? (car pattern) env))
1797 "Procedure name must be an identifier"))
1799 (and (check-c-function-type arg-typs-source res-typ-source #f)
1800 (cond ((not (string? name))
1803 "Fourth argument to 'c-define' must be a string"))
1804 ((not (valid-c-or-c++-function-id? name))
1807 "Ill-formed C function identifier"))
1808 ((not (string? scope))
1811 "Fifth argument to 'c-define' must be a string"))
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)))
1823 (cons (make-source **lambda-sym loc)
1824 (cons (parms->source (cdr (source-code (cadr code))) loc)
1825 (cdr (cddddr code))))
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
1853 "Ill-terminated C function argument type list")
1854 (let loop ((lst arg-typs))
1856 (and (check-c-type (car lst) err-source #f) ; void not allowed
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)))
1870 (let ((len (proper-length (cdr typ))))
1872 (let ((head (source-code (car typ))))
1874 (define (check pointer? err-msg)
1877 (let* ((x-source (cadr typ))
1878 (x (source-code x-source)))
1883 #t) ; allow all types
1885 (valid-c-or-c++-type-id? x))))
1887 (let ((tag (source-code (caddr typ))))
1888 (or (false-object? tag)
1889 (symbol-object? tag)
1898 (let ((id (source-code (cadddr typ))))
1899 (or (false-object? id)
1901 (valid-c-or-c++-function-id? id))))))
1902 (c-type-pt-syntax-error
1907 (define (check-function err-msg)
1909 (check-c-function-type
1913 (c-type-pt-syntax-error
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"))
1933 (ill-formed-c-type))))
1935 (c-type-pt-syntax-error
1938 "Ill-terminated C type"))))
1940 (or (valid-c-or-c++-type-id? typ)
1941 (c-type-pt-syntax-error
1944 "Ill-formed C type identifier")))
1945 ((symbol-object? typ)
1946 (if (eq? typ void-sym)
1948 (c-type-pt-syntax-error
1951 "Ill-placed C VOID type"))
1952 (let ((x (assq typ c-interface-types)))
1954 (let ((def (cdr x)))
1955 (case (vector-ref def 0)
1963 (c-type-pt-syntax-error
1966 "Undefined C type identifier:"
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)))
1976 (let ((def (cdr x)))
1977 (if (eq? (vector-ref def 0) 'alias)
1978 (resolve-type (vector-ref def 1))
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)))
1992 (let ((head (source-code (car typ))))
1993 (or (eq? head struct-sym)
1994 (eq? head union-sym)
1996 (eq? head function-sym)
1997 (eq? head nonnull-function-sym))))
2000 ((symbol-object? typ)
2001 (let ((x (assq typ c-interface-types)))
2003 (let ((def (cdr x)))
2004 (case (vector-ref def 0)
2008 (type-needs-cleanup? (vector-ref def 1)))))
2013 (define (type-accessed-indirectly? typ-source)
2014 (let ((typ (source-code typ-source)))
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)
2025 ((eq? head nonnull-pointer-sym)
2026 '#("NONNULLPOINTER" #f))
2027 ((eq? head function-sym)
2029 ((eq? head nonnull-function-sym)
2030 '#("NONNULLFUNCTION" #f))
2034 (vector "TYPE" typ))
2035 ((symbol-object? typ)
2036 (let ((x (assq typ c-interface-types)))
2038 (let ((def (cdr x)))
2039 (case (vector-ref def 0)
2043 (type-accessed-indirectly? (vector-ref def 1)))))
2048 (define (pt-c-lambda source env use)
2051 (c-lambda-param-types source)
2052 (c-lambda-result-type source)
2053 (source-code (c-lambda-proc-name source)))))
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 '()))
2070 (loop (+ i 1) (cdr lst1) (cons (cons (car lst1) i) lst2))
2073 (define (c-type-converter to-scmobj? typ from to)
2076 (compiler-internal-error "c-type-converter, unknown C type"))
2078 (define (convert kind name tag id)
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)))
2089 (- (- c-interface-obj-count x) 1)
2090 (let ((n c-interface-obj-count))
2091 (add-c-obj tag-list)
2096 (cond ((eq? kind pointer-sym)
2097 "POINTER_TO_SCMOBJ(")
2098 ((eq? kind nonnull-pointer-sym)
2099 "NONNULLPOINTER_TO_SCMOBJ(")
2102 (cond ((eq? kind struct-sym)
2103 "STRUCT_TO_SCMOBJ(")
2104 ((eq? kind union-sym)
2110 from "_voidstar," tag-str ","
2111 (if (false-object? id)
2112 (if (or (eq? kind pointer-sym)
2113 (eq? kind nonnull-pointer-sym))
2120 (assoc descr c-interface-release-fns)))
2124 c-interface-release-fn-count)
2129 (number->string i))))
2130 (set! c-interface-release-fn-count
2132 (set! c-interface-release-fns
2133 (cons (cons descr release-fn)
2134 c-interface-release-fns))
2138 (cond ((eq? kind struct-sym)
2139 "DEF_RELEASE_FN_STRUCT(")
2140 ((eq? kind union-sym)
2141 "DEF_RELEASE_FN_UNION(")
2143 "DEF_RELEASE_FN_TYPE("))
2153 (cond ((eq? kind pointer-sym)
2154 "SCMOBJ_TO_POINTER(")
2155 ((eq? kind nonnull-pointer-sym)
2156 "SCMOBJ_TO_NONNULLPOINTER(")
2159 (cond ((eq? kind struct-sym)
2160 "SCMOBJ_TO_STRUCT(")
2161 ((eq? kind union-sym)
2167 from "," to "_voidstar," tag-str))))
2169 (let ((t (source-code typ)))
2171 (let ((head (source-code (car t)))
2172 (len (length (cdr t))))
2173 (cond ((or (eq? head struct-sym)
2174 (eq? head union-sym)
2176 (eq? head pointer-sym)
2177 (eq? head nonnull-pointer-sym))
2180 (source-code (cadr t))
2182 (source->expression (caddr t))
2183 (string->symbol (c-type-decl typ "")))
2185 (source-code (cadddr t))
2187 ((or (eq? head function-sym)
2188 (eq? head nonnull-function-sym))
2191 (if (eq? head function-sym)
2192 "FUNCTION_TO_SCMOBJ("
2193 "NONNULLFUNCTION_TO_SCMOBJ(")
2194 from "_voidstar," to)
2196 (fn-param-converter typ)))
2198 (if (eq? head function-sym)
2199 "SCMOBJ_TO_FUNCTION("
2200 "SCMOBJ_TO_NONNULLFUNCTION(")
2201 from "," converter "," to "_voidstar"))))
2211 (let ((x (assq t c-interface-types)))
2213 (let ((def (cdr x)))
2214 (case (vector-ref def 0)
2233 (define nl-str (string #\newline))
2235 (define (c-preproc-define id val body)
2237 "#define " id " " val nl-str
2239 "#undef " id nl-str))
2241 (define (c-preproc-define-default-empty id body)
2245 "#ifndef " id nl-str
2246 "#define " id nl-str
2249 (define (c-result sfun? scheme-side?)
2253 (if sfun? "SFUN_RESULT" "CFUN_RESULT")
2256 (define (c-argument scheme-side? numbered-typ)
2257 (let ((i (number->string (cdr numbered-typ))))
2260 (if scheme-side? "ARG" "arg")
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)))
2273 (if sfun? "BEGIN_SFUN_ARG_SCMOBJ(" "BEGIN_CFUN_ARG_SCMOBJ(")
2274 (if sfun? "BEGIN_SFUN_ARG(" "BEGIN_CFUN_ARG("))
2283 (string-append "void* " c-id "_voidstar")
2284 (c-type-decl typ c-id)))))
2288 (if (vector-ref indirect-access 1)
2291 (vector-ref indirect-access 0)
2293 (vector-ref indirect-access 1)
2299 c-id-prefix "BEGIN_SFUN_COPY_" tail
2301 c-id-prefix "END_SFUN_COPY_" tail))
2303 (string-append c-id "_voidstar")
2304 (string-append c-id-prefix "SFUN_CAST(void*," c-id ")")
2310 (if (vector-ref indirect-access 1)
2312 "CFUN_CAST_AND_DEREF("
2313 (c-type-decl typ "*"))
2316 (c-type-decl typ "")))
2323 (if sfun? "END_SFUN_ARG_SCMOBJ(" "END_CFUN_ARG_SCMOBJ(")
2324 (if sfun? "END_SFUN_ARG(" "END_CFUN_ARG("))
2327 (define (c-convert-representation sfun? to-scmobj? typ from to i body)
2330 (c-type-converter to-scmobj? typ from to)
2331 (if i (string-append "," i) "")
2334 c-id-prefix (if sfun? "BEGIN_SFUN_" "BEGIN_CFUN_") tail
2336 c-id-prefix (if sfun? "END_SFUN_" "END_CFUN_") tail)))
2338 (define (c-convert-argument sfun? numbered-typ body)
2342 (c-argument (not sfun?) numbered-typ))
2344 (c-argument sfun? numbered-typ))
2346 (number->string (cdr 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)))))
2365 (define (c-set-result sfun? result-typ)
2366 (cond ((void-type? result-typ)
2369 (if sfun? "SFUN_SET_RESULT_VOID" "CFUN_SET_RESULT_VOID")
2371 ((scmobj-type? result-typ)
2374 (if sfun? "SFUN_SET_RESULT_SCMOBJ" "CFUN_SET_RESULT_SCMOBJ")
2377 (c-convert-representation
2381 (c-result sfun? sfun?)
2382 (c-result sfun? (not sfun?))
2386 (if sfun? "SFUN_SET_RESULT" "CFUN_SET_RESULT")
2389 (define (c-make-function sfun? param-typs result-typ make-body)
2391 (not (every? (lambda (t) (not (type-needs-cleanup? t)))
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?)
2411 (convert (cdr numbered-typs)))))))
2415 (string-append c-id-prefix "NARGS")
2417 (number->string (length param-typs))
2419 (if (void-type? result-typ)
2430 (convert-param-list)
2434 (if cleanup? "CFUN_ERROR_CLEANUP_VOID" "CFUN_ERROR_VOID"))
2437 (c-set-result sfun? result-typ)
2440 (if sfun? "END_SFUN_VOID" "END_CFUN_VOID") nl-str)
2443 (c-result sfun? #f))
2445 (scmobj-type? result-typ))
2446 (indirect-access-result
2447 (type-accessed-indirectly? result-typ))
2454 "BEGIN_SFUN_SCMOBJ("
2457 "BEGIN_CFUN_SCMOBJ")
2465 (if indirect-access-result
2466 (string-append "void* " c-id "_voidstar"
2467 (if sfun? " = 0" ""))
2468 (c-type-decl result-typ c-id))
2471 (convert-param-list)
2476 (if cleanup? "CFUN_ERROR_CLEANUP_SCMOBJ" "CFUN_ERROR_SCMOBJ"))
2479 (if cleanup? "CFUN_ERROR_CLEANUP" "CFUN_ERROR")))
2482 (c-set-result sfun? result-typ)
2486 (if sfun? "END_SFUN_SCMOBJ" "END_CFUN_SCMOBJ")
2487 (if sfun? "END_SFUN" "END_CFUN"))
2490 (string-append "return " c-id ";" nl-str)
2492 (if indirect-access-result
2498 (if sfun? "SFUN_CAST_AND_DEREF(" "CFUN_CAST_AND_DEREF(")
2499 (c-type-decl result-typ "*")
2501 (if (vector-ref indirect-access-result 1)
2509 (define (comma-separated strs)
2514 (apply string-append
2515 (map (lambda (s) (string-append "," s)) (cdr strs))))))
2517 (define (c-type-decl typ inner)
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)))
2530 (let ((head (source-code (car t))))
2531 (cond ((eq? head struct-sym)
2533 (string-append "struct " (source-code (cadr t)))))
2534 ((eq? head union-sym)
2536 (string-append "union " (source-code (cadr t)))))
2537 ((eq? head type-sym)
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)
2549 (c-param-list-with-types
2550 (source-code (cadr t))))))
2556 (let ((x (assq t c-interface-types)))
2558 (let ((def (cdr x)))
2559 (case (vector-ref def 0)
2561 (prefix-inner (vector-ref def 1)))
2563 (c-type-decl (vector-ref def 1) inner))))
2568 (define (c-param-list-with-types typs)
2570 (string-append c-id-prefix "PVOID")
2574 (comma-separated (map (lambda (typ) (c-type-decl typ "")) typs))
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")
2587 (map (lambda (t) (c-type-decl (car t) (c-param-id t)))
2590 (comma-separated (map c-param-id numbered-typs))
2592 (apply string-append
2596 (c-type-decl (car t) (c-param-id t))
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
2609 (c-param-list-with-ids numbered-typs)
2610 (c-param-list-with-types param-typs))))))
2614 function-decl nl-str
2615 "{" nl-str body "}" nl-str)
2617 function-decl ";" nl-str)))))
2619 (define (c-function param-typs result-typ proc-name c-defined? scope)
2623 c-id-prefix "MLBL(" c-id-prefix "C_LBL_" proc-name ")")
2625 c-id-prefix "FAL"))))
2627 (define (make-body set-result-code cleanup?)
2629 c-id-prefix "BEGIN_SFUN_BODY" nl-str
2630 (let convert ((numbered-typs (number-from-1 param-typs)))
2631 (if (null? numbered-typs)
2634 (cond ((void-type? result-typ)
2636 ((scmobj-type? result-typ)
2641 (let ((numbered-typ (car numbered-typs)))
2645 (number->string (cdr numbered-typ))
2647 (c-argument #t numbered-typ)
2649 (convert (cdr numbered-typs))))))
2651 c-id-prefix "END_SFUN_BODY" nl-str))
2654 (c-function-decl param-typs
2658 (c-make-function proc-val
2663 (define (fn-param-converter typ)
2664 (let ((function-c-type (c-type-decl typ "")))
2665 (cond ((assoc function-c-type c-interface-converters)
2672 (source-code (cadr t)))
2676 c-interface-converter-count)
2681 (number->string i))))
2682 (set! c-interface-converter-count
2684 (set! c-interface-converters
2685 (cons (cons function-c-type converter)
2686 c-interface-converters))
2692 (string-append c-id-prefix "LOCAL"))
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)
2703 (number->string c-interface-proc-count))
2705 (string-append module-prefix c-interface-module-name "#" index))
2707 (string-append c-id-prefix (scheme-id->c-id scheme-name)))
2709 (length param-typs))
2710 (stripped-param-typs
2711 (strip-param-typs param-typs)))
2713 (define (make-body set-result-code cleanup?)
2716 (if cleanup? "BEGIN_CFUN_BODY_CLEANUP" "BEGIN_CFUN_BODY")
2718 (c-preproc-define-default-empty
2719 (string-append c-id-prefix "AT_END")
2721 (if (valid-c-or-c++-function-id? proc-name)
2724 (indirect-access-result
2725 (type-accessed-indirectly? result-typ))
2730 (map c-param-id (number-from-1 stripped-param-typs)))
2732 (cond ((void-type? result-typ)
2738 (indirect-access-result
2739 (if (vector-ref indirect-access-result 1)
2743 (vector-ref indirect-access-result 0)
2745 (vector-ref indirect-access-result 1)
2753 (vector-ref indirect-access-result 0)
2769 (if cleanup? "END_CFUN_BODY_CLEANUP" "END_CFUN_BODY")
2773 (make-c-proc scheme-name
2782 (define (scheme-id->c-id s)
2783 (let loop1 ((i (- (string-length s) 1)) (lst '()))
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)))
2791 (let ((n (character->unicode c)))
2793 (loop1 (- i 1) (cons #\_ (cons #\0 (cons #\_ lst))))
2794 (let loop2 ((n n) (lst (cons #\_ lst)))
2796 (loop2 (quotient n 16)
2797 (cons (string-ref "0123456789abcdef"
2800 (loop1 (- i 1) (cons #\_ 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))
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))
2814 (and (>= n 48) (<= n 57)))))
2816 (define (valid-c-id? id type?)
2817 (let ((n (string-length id)))
2819 (c-id-initial? (string-ref id 0))
2820 (let loop ((i 1) (depth 0))
2822 (let ((c (string-ref id i)))
2823 (cond ((and (< (+ i 2) n)
2825 (char=? #\: (string-ref id (+ i 1)))
2826 (c-id-initial? (string-ref id (+ i 2))))
2827 (loop (+ i 3) depth))
2831 (c-id-initial? (string-ref id (+ i 1))))
2832 (loop (+ i 2) (+ depth 1)))
2835 (c-id-initial? (string-ref id (+ i 1)))
2837 (loop (+ i 2) depth))
2838 ((and (char=? #\> c)
2840 (loop (+ i 1) (- depth 1)))
2841 ((c-id-subsequent? c)
2842 (loop (+ i 1) depth))
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 ;;;============================================================================