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

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

Some more updates to the front end interface.

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