blob: 26e0591d6a1fbf8c9615a8440641af1e19cfb54f (
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
|
(define-library (csc cps)
(export
ir1->ir2)
(import (only (csc gensym) gensym)
(only (csc hash-map)
alist->map
insert
merge)
(only (csc ir1)
constant?
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)
(only (csc ir2)
make-atom
make-kargs
make-ktail
make-update)
(scheme base))
(begin
(define (make-soup . l)
(alist->map (lambda (x) x) < l))
(define (new-ref)
(make-lexical-ref 'generated-symbol (gensym)))
(define-syntax cps-merge
(syntax-rules ()
((cps-merge new-continuations sub-cps)
(let-values (((expr soup) sub-cps))
(values expr (merge soup new-continuations))))))
(define (to-cps expr continuation next-id)
(cond
((or (constant? expr)
(lexical-ref? expr)
(library-ref? expr))
(values (make-atom expr continuation) (make-soup)))
((lexical-set? expr)
(let ((id (next-id))
(ref (new-ref)))
(cps-merge
(make-soup (cons id (make-kargs (list ref)
(make-update (lexical-set-ref expr) ref continuation))))
(to-cps (lexical-set-expression expr) id next-id))))
((library-define? expr)
(let ((id (next-id))
(ref (new-ref)))
(cps-merge
(make-soup (cons id (make-kargs (list ref)
(make-update (library-define-ref expr) ref continuation))))
(to-cps (library-define-expression expr) id next-id))))
(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 (next-id)
(set! current-continuation-id (+ 1 current-continuation-id))
current-continuation-id)
(define ktail (next-id))
(define-values (expr m) (to-cps program ktail next-id))
(set! m (insert m ktail (make-ktail)))
(set! m (insert m 0 (make-kargs '() expr)))
m)))
|
