-
Notifications
You must be signed in to change notification settings - Fork 1
/
xaraa.rkt
150 lines (147 loc) · 6.73 KB
/
xaraa.rkt
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
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
#lang racket
(require racket/mpair)
(require "x-misc.rkt")
(define (uaraa:analyze-parameter-access! prog types)
(define types-modified? #f)
(define (collect-acc-prog!)
(for-each
(lambda (fundef)
(let ((body (cadddr fundef))
(parlist (cadr fundef))
(fname (car fundef)))
(collect-acc-exp! body '() fname parlist)))
prog))
(define (collect-acc-exp! exp context fn vn)
(cond ((symbol? exp)
(when (not (null? context))
(begin (contract-var! exp context fn vn))))
((equal? (car exp) 'quote) #f)
((equal? (car exp) 'car)
(let ((exp1 (cadr exp)))
(collect-acc-exp! exp1 `(car unquote context) fn vn)))
((equal? (car exp) 'cdr)
(let ((exp1 (cadr exp)))
(collect-acc-exp! exp1 `(cdr unquote context) fn vn)))
((equal? (car exp) 'cons)
(let ((exp2 (caddr exp)) (exp1 (cadr exp)))
(collect-acc-exp! exp1 (un-car context) fn vn)
(collect-acc-exp! exp2 (un-cdr context) fn vn)))
((equal? (car exp) 'call)
(let ((exp* (cddr exp)) (fname (cadr exp)))
(let ((%%74 (massq fname types)))
(let ((arg-type* (mcdr %%74)))
(collect-acc-arg*! exp* arg-type* fn vn)))))
((equal? (car exp) 'xcall)
(let ((exp* (cddr exp)) (fname (cadr exp)))
(collect-acc-exp*! exp* fn vn)))
(else
(let ((exp* (cdr exp)) (op (car exp)))
(collect-acc-exp*! exp* fn vn)))))
(define (collect-acc-exp*! exp* fn vn)
(for-each (lambda (exp) (collect-acc-exp! exp '() fn vn)) exp*))
(define (collect-acc-arg*! exp* patt* fn vn)
(for-each
(lambda (exp patt) (collect-acc-exp! exp (patt->context patt) fn vn))
exp*
patt*))
(define (update-types! func)
(mfor-each
(lambda (fdescr)
(let ((type* (mpairs->pairs (mcdr fdescr))) (fname (mcar fdescr))) ; conveting back to regular pairs
(set-mcdr! fdescr (map func type*))))
types))
(define (mark-conses type)
(cond ((equal? type 'absent) 'any)
((equal? type 'any) type)
((equal? (car type) 'atom) type)
((equal? (car type) 'cons)
(let ((t2 (caddr type)) (t1 (cadr type)))
`(cons? ,(mark-conses t1) ,(mark-conses t2))))
(else (error "SELECT: no match for" type))))
(define (generalize-type type)
(cond ((equal? type 'any) type)
((equal? (car type) 'atom) type)
((equal? (car type) 'cons)
(let ((t2 (caddr type)) (t1 (cadr type)))
`(cons ,(generalize-type t1) ,(generalize-type t2))))
((equal? (car type) 'cons?) 'any)
(else (error "SELECT: no match for" type))))
(define (patt->context patt)
(cond ((equal? patt 'any) '())
((equal? (car patt) 'atom) '())
((equal? (car patt) 'cons) patt)
((equal? (car patt) 'cons?) '())
(else (error "SELECT: no match for" patt))))
(define (un-car context)
(cond ((null? context) '())
((equal? (car context) 'car) (let ((rest (cdr context))) rest))
((equal? (car context) 'cdr) (let ((rest (cdr context))) '()))
((equal? (car context) 'cons)
(let ((p2 (caddr context)) (p1 (cadr context))) (patt->context p1)))
(else (error "SELECT: no match for" context))))
(define (un-cdr context)
(cond ((null? context) '())
((equal? (car context) 'car) (let ((rest (cdr context))) '()))
((equal? (car context) 'cdr) (let ((rest (cdr context))) rest))
((equal? (car context) 'cons)
(let ((p2 (caddr context)) (p1 (cadr context))) (patt->context p2)))
(else (error "SELECT: no match for" context))))
(define (contract-var! vname context fname vn)
(let ((%%75 (massq fname types)))
(let ((fdescr %%75))
(let ((type* (mcdr fdescr)))
(set-mcdr! fdescr (contract-par context vname vn type*))))))
(define (contract-par context par vname* type*)
(let ((r-vname* (cdr vname*)) (vname (car vname*)))
(let ((r-type* (cdr type*)) (type (car type*)))
(if (eq? par vname)
`(,(contract-type context type) unquote r-type*)
`(,type unquote (contract-par context par r-vname* r-type*))))))
(define (contract-type context type)
(cond ((null? context) type)
((equal? (car context) 'car)
(let ((rest (cdr context)))
(cond ((equal? type 'any) type)
((equal? (car type) 'atom) type)
((equal? (car type) 'cons)
(let ((t2 (caddr type)) (t1 (cadr type)))
`(cons ,(contract-type rest t1) ,t2)))
((equal? (car type) 'cons?)
(let ((t2 (caddr type)) (t1 (cadr type)))
`(cons ,(contract-type rest t1) ,t2)))
(else (error "SELECT: no match for" type)))))
((equal? (car context) 'cdr)
(let ((rest (cdr context)))
(cond ((equal? type 'any) type)
((equal? (car type) 'atom) type)
((equal? (car type) 'cons)
(let ((t2 (caddr type)) (t1 (cadr type)))
`(cons ,t1 ,(contract-type rest t2))))
((equal? (car type) 'cons?)
(let ((t2 (caddr type)) (t1 (cadr type)))
`(cons ,t1 ,(contract-type rest t2))))
(else (error "SELECT: no match for" type)))))
(else (let ((patt context)) (match-types patt type)))))
(define (match-types patt type)
(cond ((equal? patt 'any) type)
((equal? (car patt) 'atom) type)
((equal? (car patt) 'cons)
(let ((p2 (caddr patt)) (p1 (cadr patt)))
(cond ((equal? type 'any) type)
((equal? (car type) 'atom) type)
((equal? (car type) 'cons)
(let ((t2 (caddr type)) (t1 (cadr type)))
`(cons ,(match-types p1 t1) ,(match-types p2 t2))))
((equal? (car type) 'cons?)
(let ((t2 (caddr type)) (t1 (cadr type)))
`(cons ,(match-types p1 t1) ,(match-types p2 t2))))
(else (error "SELECT: no match for" type)))))
((equal? (car patt) 'cons?) type)
(else (error "SELECT: no match for" patt))))
(update-types! mark-conses)
(let recalc-accesses! ()
(display "*")
(set! types-modified? #f)
(collect-acc-prog!)
(if types-modified? (recalc-accesses!) (update-types! generalize-type))))
(provide (all-defined-out))