-
Notifications
You must be signed in to change notification settings - Fork 1
/
xfcd.rkt
116 lines (114 loc) · 4.42 KB
/
xfcd.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
#lang racket
(require racket/mpair)
(require "x-misc.rkt")
(define (ufcd:find-congruent-division prog descr)
(define meta-confs #f)
(define meta-confs-modified? #f)
(define (collect-mc-prog!)
(for-each
(lambda (fundef)
(let ((body (cadddr fundef))
(pars (cadr fundef))
(fname (car fundef)))
(let ((%%1 (massq fname meta-confs)))
(let ((res (mcddr %%1)) (args (mcadr %%1)))
(update-mc!
fname
args
(abstract-eval body pars args))
(collect-mc! body pars args)))))
prog))
(define (collect-mc! exp vn vv)
(cond ((symbol? exp) #f)
((equal? (car exp) 'quote)
(let ((exp (cadr exp))) #f))
((let ((fname_exp* (cdr exp)) (call? (car exp)))
(memq call? '(call rcall)))
(let ((fname_exp* (cdr exp)) (call? (car exp)))
(let ((exp* (cdr fname_exp*))
(fname (car fname_exp*)))
(let ((%%2 (collect-mc*! exp* vn vv)))
(let ((%%3 (abstract-eval* exp* vn vv)))
(let ((args %%3))
(let ((%%4 (lub-list args)))
(let ((res %%4)) (update-mc! fname args res)))))))))
((equal? (car exp) 'xcall)
(let ((exp* (cddr exp)) (fname (cadr exp)))
(collect-mc*! exp* vn vv)))
(else
(let ((exp* (cdr exp)) (op (car exp)))
(collect-mc*! exp* vn vv)))))
(define (collect-mc*! exp* vn vv)
(for-each
(lambda (exp) (collect-mc! exp vn vv))
exp*))
(define (abstract-eval exp vn vv)
(cond ((symbol? exp) (lookup-variable exp vn vv))
((equal? (car exp) 'quote)
(let ((exp (cadr exp))) 's))
((equal? (car exp) 'generalize)
(let ((exp (cadr exp))) 'd))
((let ((fname_exp* (cdr exp)) (call? (car exp)))
(memq call? '(call rcall)))
(let ((fname_exp* (cdr exp)) (call? (car exp)))
(let ((exp* (cdr fname_exp*))
(fname (car fname_exp*)))
(let ((%%5 (massq fname meta-confs)))
(let ((fres (mcddr %%5)) (fargs (mcadr %%5))) fres)))))
((equal? (car exp) 'xcall)
(let ((exp* (cddr exp)) (fname (cadr exp)))
(lub-list (abstract-eval* exp* vn vv))))
(else
(let ((exp* (cdr exp)) (op (car exp)))
(lub-list (abstract-eval* exp* vn vv))))))
(define (abstract-eval* exp* vn vv)
(map (lambda (exp) (abstract-eval exp vn vv))
exp*))
(define (lub ind1 ind2)
(if (eq? ind1 'd) 'd ind2))
(define (lub-list ind*)
(if (memq 'd ind*) 'd 's))
(define (initial-meta-confs prog)
(map (lambda (fundef)
(let ((fpars (cadr fundef)) (fname (car fundef)))
`(,fname ,(map (lambda (par) 's) fpars) . s)))
prog))
(define (update-mc! fname args res)
(let ((%%6 (massq fname meta-confs)))
(let ((fdescr %%6))
(let ([res1 (mcddr fdescr)]
[args1 (mpairs->pairs (mcadr fdescr))])
(let ([%%7 (map lub (mpairs->pairs args) args1)])
(let ((lub-args %%7))
(let ((%%8 (lub res res1)))
(let ((lub-res %%8))
(when (or (not (equal? lub-args args1))
(not (equal? lub-res res1)))
(begin
; for debug
(display (format "Before: ~s" fdescr))
(set-mcdr! fdescr (pairs->mpairs `(,lub-args unquote lub-res)))
(display (format "After: ~s" fdescr))
(set! meta-confs-modified? #t)))))))))))
(define (lookup-variable vname vn vv)
(if (and (null? vn) (null? vv))
(error "Undefined variable: " vname)
(let ((vrest (mcdr vv))
(vv (mcar vv))
(nrest (cdr vn))
(vn (car vn)))
(if (eq? vname vn)
vv
(lookup-variable vname nrest vrest)))))
(let ((prog-rest (cdr prog)) (fname (caar prog)))
(set! meta-confs
(pairs->mpairs `((,fname ,descr unquote (lub-list descr)) ; converting to mutable list
unquote
(initial-meta-confs prog-rest)))))
(let recalc-mc! ()
(display "*")
(set! meta-confs-modified? #f)
(collect-mc-prog!)
(display meta-confs-modified?)
(if meta-confs-modified? (recalc-mc!) meta-confs)))
(provide (all-defined-out))