blob: 55e7e8160385f982a0bcad8c197e23b84ab10bf7 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
(define-library (csc cps)
(export
ir1->ir2)
(import (only (csc gensym) gensym)
(only (csc hash-map)
insert
make-map
merge)
(only (csc ir1)
call-arguments
call-procedure
call?
constant?
define-syntax?
if-alternate
if-consequent
if-test
if?
lexical-ref?
lexical-set-expression
lexical-set-ref
lexical-set?
library-define-expression
library-define-ref
library-define?
library-ref?
make-constant
make-lexical-ref
sequence-head
sequence-tail
sequence?)
(only (csc ir2)
make-atom
make-branch
make-call-closure
make-kargs
make-klabel
make-ktail
make-update)
(only (csc loop)
loop
return)
(scheme base))
(begin
(define (new-ref)
(make-lexical-ref 'generated-symbol (gensym)))
(define (to-cps expr continuation add-continuation)
(cond
((or (constant? expr)
(lexical-ref? expr)
(library-ref? expr))
(make-atom expr continuation))
((lexical-set? expr)
(let ((ref (new-ref)))
(to-cps
(lexical-set-expression expr)
(add-continuation
(make-kargs (list ref)
(make-update (lexical-set-ref expr) ref continuation)))
add-continuation)))
((library-define? expr)
(let ((ref (new-ref)))
(to-cps
(library-define-expression expr)
(add-continuation
(make-kargs (list ref)
(make-update (library-define-ref expr) ref continuation)))
add-continuation)))
((define-syntax? expr)
; no-op
(make-atom (make-constant #f) continuation))
((if? expr)
(let* ((true-id (add-continuation
(make-klabel
(to-cps (if-consequent expr) continuation add-continuation))))
(false-id (add-continuation
(make-klabel
(to-cps (if-alternate expr) continuation add-continuation))))
(test-ref (new-ref))
(branch-id (add-continuation
(make-kargs (list test-ref)
(make-branch test-ref true-id false-id)))))
(to-cps (if-test expr) branch-id add-continuation)))
((call? expr)
; Technically the order of evaluation is unspecified. We evaluate
; expressions left to right.
(loop with terms = (cons (call-procedure expr) (call-arguments expr))
with temps = (map (lambda (x) (new-ref)) terms)
with expr = (make-call-closure (car temps) (cdr temps) continuation)
for term in (reverse terms)
for temp in (reverse temps)
do (set! expr (to-cps term
(add-continuation
(make-kargs (list temp) expr))
add-continuation))
finally (return expr)))
((sequence? expr)
(to-cps
(sequence-head expr)
(add-continuation
(make-klabel
(to-cps (sequence-tail expr) continuation add-continuation)))
add-continuation))
(else (error "unexpected type in to-cps" expr))))
; Returns a map from integers to CPS continuations.
; By convention the continuation at key 0 is the entrypoint.
(define (ir1->ir2 program)
(define current-continuation-id 0)
(define soup (make-map (lambda (x) x) <))
(define (add-continuation continuation)
(set! current-continuation-id (+ 1 current-continuation-id))
(set! soup (insert soup
current-continuation-id
continuation))
current-continuation-id)
(define ktail (add-continuation (make-ktail)))
(define entrypoint (to-cps program ktail add-continuation))
(insert soup 0 (make-klabel entrypoint)))))
|
