source: project/release/3/prescheme-compiler/front/cps.scm @ 11695

Last change on this file since 11695 was 11695, checked in by Ivan Raikov, 12 years ago

Some more updates to the node and front modules.

File size: 4.0 KB
Line 
1; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
2
3; (cps-call <primop> <exits> <first-arg-index> <args> <cps>) ->
4;                   <call-node> + <top-call-node> + <bottom-lambda-node>
5;
6; (cps-sequence <nodes> <cps>) -> <last-node> + <top-call> + <bottom-lambda>
7;
8; (<cps> <node>) -> <value-node> + <top-call-node> + <bottom-lambda-node>
9
10(define (cps-call primop exits first-arg-index args cps)
11  (let ((call (make-call-node primop
12                              (+ (length args) first-arg-index)
13                              exits))
14        (arguments (make-arg-nodes args first-arg-index cps)))
15    (let loop ((args arguments) (first #f) (last #f))
16      (if (null? args)
17          (values call first last)
18          (let ((arg (car args)))
19            (attach call (arg-index arg) (arg-value arg))
20            (if (and last (arg-first arg))
21                (attach-body last (arg-first arg)))
22            (loop (cdr args)
23                  (or first (arg-first arg))
24                  (or (arg-last arg) last)))))))
25           
26; Record to hold information about arguments to calls.
27
28(define-record-type arg 
29  (make-arg index rank value first last)
30  arg?
31  (index arg-index)  ; The index of this argument in the call.
32  (rank arg-rank)    ; The estimated cost of executing this node at run time.
33  (value arg-value)  ; What CPS returned for this argument.
34  (first arg-first)
35  (last arg-last))
36
37; Convert the elements of EXP into nodes (if they aren't already) and put
38; them into an ARG record.  Returns the list of ARG records sorted
39; by ARG-RANK.
40
41(define (make-arg-nodes exp start cps)
42  (do ((index start (+ index 1))
43       (args exp (cdr args))
44       (vals '() (cons (receive (value first last)
45                           (cps (car args))
46                         (make-arg index (node-rank first) value first last))
47                       vals)))
48      ((null? args)
49       (sort-list vals
50                  (lambda (v1 v2)
51                    (> (arg-rank v1) (arg-rank v2)))))))
52
53; Complexity analysis used to order argument evaluation.  More complex
54; arguments are to be evaluated first.  This just counts reference nodes.
55; It is almost certainly a waste of time.
56
57(define (node-rank first)
58  (if (not first)
59      0
60      (complexity-analyze-vector (call-args first))))
61
62(define (complexity-analyze node)
63  (cond ((empty? node)
64         0)
65        ((reference-node? node)
66         1)
67        ((lambda-node? node)
68         (if (not (empty? (lambda-body node)))
69             (complexity-analyze-vector (call-args (lambda-body node)))
70             0))
71        ((call-node? node)
72         (complexity-analyze-vector (call-args node)))
73        (else
74         0)))
75
76(define (complexity-analyze-vector vec)
77  (do ((i 0 (+ i 1))
78       (q 0 (+ q (complexity-analyze (vector-ref vec i)))))
79      ((>= i (vector-length vec))
80       q)))
81
82;----------------------------------------------------------------
83; (cps-sequence <nodes> <values-cps>) ->
84;   <last-node> + <top-call> + <bottom-lambda>
85; <values-cps> is the same as the <cps> used above, except that it returns
86; a list of value nodes instead of exactly one.
87
88(define (cps-sequence nodes values-cps)
89  (if (null? nodes)
90      (bug "CPS: empty sequence"))
91  (let loop ((nodes nodes) (first #f) (last #f))
92    (if (null? (cdr nodes))
93        (values (car nodes) first last)
94        (receive (exp-first exp-last)
95            (cps-sequent (car nodes) values-cps)
96          (if (and last exp-first)
97              (attach-body last exp-first))
98          (loop (cdr nodes) (or first exp-first) (or exp-last last))))))
99
100(define (cps-sequent node values-cps)     
101  (receive (vals exp-first exp-last)
102      (values-cps node)
103    (receive (calls other)
104        (partition-list call-node? vals)
105      (map erase other)
106      (if (null? calls)
107          (values exp-first exp-last)
108          (insert-let calls exp-first exp-last)))))
109
110(define (insert-let calls exp-first exp-last)
111  (let* ((vars (map (lambda (call)
112                      (make-variable 'v (trivial-call-return-type call)))
113                    calls))
114         (cont (make-lambda-node 'c 'cont vars))
115         (call (make-call-node (get-primop (enum primop let))
116                               (+ 1 (length calls))
117                               1)))
118    (attach-call-args call (cons cont calls))
119    (cond (exp-first
120           (attach-body exp-last call)
121           (values exp-first cont))
122          (else
123           (values call cont)))))
124
Note: See TracBrowser for help on using the repository browser.