-
Notifications
You must be signed in to change notification settings - Fork 2
/
rewrite.lisp
189 lines (162 loc) · 5.82 KB
/
rewrite.lisp
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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
;;; Style of rule ref [1: 39] means ref 1 equation 39
;;; References
;;; 1. Backus Turing Lecture
;;; 2. FP optimization
(load "pat-match.lisp")
(load "macros.lisp")
(defparameter *fl-rewrites* nil
"A list of all rules available for rewrite")
(defun fl-pattern (ref)
"Get pattern for given reference"
(first (cdr (assoc ref *fl-rewrites*))))
(defun fl-action (ref)
"Get rewrite for given reference"
(second (cdr (assoc ref *fl-rewrites*))))
(defun add-fl-rewrite (&key pattern action ref)
"Add reference and its reverse to the rulebase"
(pushnew (cons ref (list pattern action)) *fl-rewrites*))
(defun binding-p (binding)
"Check if binding is successful"
(not (eq binding nil)))
(add-fl-rewrite
:pattern '(comp (idx (?is ?i integerp))
(cat (?* ?fn-list)))
:action #'(lambda (binding)
(nth (lookup '?i binding) (lookup '?fn-list binding)))
:ref '2-3)
(add-fl-rewrite
:pattern '(comp (const ?x) ?y)
:action #'(lambda (binding) (sublis binding '(const ?x)))
:ref '2-14)
(add-fl-rewrite
:pattern '(comp ?inside-comp)
:action #'(lambda (binding)
(lookup '?inside-comp binding))
:ref '2-21-0)
(add-fl-rewrite
:pattern '(comp (?* ?start-comp)
(comp (?* ?inside-comp))
(?* ?end-comp))
:action #'(lambda (binding)
`(comp ,@(lookup '?start-comp binding)
,@(lookup '?inside-comp binding)
,@(lookup '?end-comp binding)))
:ref '2-21)
(add-fl-rewrite
:pattern '(comp (cat (?* ?fn-list)) ?g)
:action #'(lambda (binding)
`(cat ,@(mapcar
#'(lambda (f) (list 'comp f (lookup '?g binding)))
(lookup '?fn-list binding))))
:ref '2-25)
(add-fl-rewrite
:pattern '(for-loop ?i (const (?is ?start integerp))
(const (?is ?end integerp)) ?body)
:action #'(lambda (binding)
(let ((i (lookup '?i binding))
(start (lookup '?start binding))
(end (lookup '?end binding))
(body (lookup '?body binding)))
`(cat ,@(loop for actual-i from start below end
collect (sublis (list (cons i actual-i)) body)))))
:ref '2-def-5.2)
(add-fl-rewrite
:pattern '(comp trans
(for-loop ?j ?r ?s
(for-loop ?i ?f ?g ?E)))
:action #'(lambda (binding)
(sublis binding '(for-loop ?i ?f ?g
(for-loop ?j ?r ?s ?E))))
:ref '2-49)
(add-fl-rewrite
:pattern '(comp distr (cat (for-loop ?i ?f ?g ?E) ?h))
:action #'(lambda (binding) (sublis binding
'(for-loop ?i ?f ?g (cat ?E ?h))))
:ref '2-51)
(add-fl-rewrite
:pattern '(comp distl (cat ?h (for-loop ?i ?f ?g ?E)))
:action #'(lambda (binding) (sublis binding
'(for-loop ?i ?f ?g (cat ?h ?E))))
:ref '2-52)
(add-fl-rewrite
:pattern '(comp (alpha ?f) (for-loop ?i ?g ?h ?E))
:action #'(lambda (binding)
(sublis binding '(for-loop ?i ?g ?h (comp ?f ?E))))
:ref '2-53)
; todo: make this more generic
(add-fl-rewrite
:pattern '(comp trans (cat (for-loop ?i1 ?f ?g ?E1)
(for-loop ?i2 ?f ?g ?E2)))
:action #'(lambda (binding)
(sublis (list (cons (lookup '?i2 binding) (lookup '?i1 binding)))
(sublis binding '(for-loop ?i1 ?f ?g (cat ?E1 ?E2)))))
:ref '2-56)
(add-fl-rewrite
:pattern '(comp (for-loop ?i ?f ?g ?E) ?h)
:action #'(lambda (binding)
(sublis binding '(for-loop ?i ?f ?g (comp ?E ?h))))
:ref '2-58)
;; Normalize comps for faster convergence
(defun check-if-normalize-rule (rule)
(member rule '(2-21-9 2-21)))
(defun normalize-comp-step (prog)
"Heuristic to make further analysis easy.
Ideally should be derivable from above."
(if (not (listp prog))
prog
(let ((binding-simple (pat-match (fl-pattern '2-21-0) prog)))
(if (binding-p binding-simple)
(funcall (fl-action '2-21-0) binding-simple)
; try yet another pattern
(let ((binding (pat-match (fl-pattern '2-21) prog)))
(if (binding-p binding)
(funcall (fl-action '2-21) binding)
; try recursively if this too failed
(mapcar #'normalize-comp-step prog)))))))
(defun normalize-comp (prog)
"Iteratively apply normalize step until prog converges"
(let ((old-prog prog)
(new-prog (normalize-comp-step prog)))
(loop while (not (equal new-prog old-prog))
do (setf old-prog new-prog)
do (setf new-prog (normalize-comp-step old-prog)))
new-prog))
(defun check-if-comp-based-rule (rule)
"Check if rule is comp based"
(eq (first (fl-pattern rule)) 'comp))
(defun apply-comp-based-rule (rule prog)
"Apply composition based rules.
Heursitic to speed up search.
Normalize prog for best performance"
(if (not (check-if-comp-based-rule rule))
(error "rule ~a doesn't start with comp" rule))
(let* ((comp-pat `(comp (?* ?start-comp)
,@(rest (fl-pattern rule))
(?* ?end-comp)))
(binding (pat-match comp-pat prog)))
(if (binding-p binding)
`(comp ,@(lookup '?start-comp binding)
,(funcall (fl-action rule) binding)
,@(lookup'?end-comp binding))
prog)))
(defun apply-rule (rule prog)
(cond
((check-if-normalize-rule rule) (normalize-comp prog))
((check-if-comp-based-rule rule) (apply-comp-based-rule rule prog))
(t (let ((bindings (pat-match (fl-pattern rule) prog)))
(if (binding-p bindings)
(funcall (fl-action rule) bindings)
prog)))))
(defun apply-rule-recursively (rule prog)
(if (not (listp prog))
prog
(let ((new-prog (apply-rule rule prog)))
(if (equal new-prog prog)
(mapcar #'(lambda (subprog)
(apply-rule-recursively rule subprog)) prog)
new-prog))))
(defun apply-rules-pipeline (rules prog)
(if (null rules)
(normalize-comp prog)
(apply-rules-pipeline (rest rules)
(apply-rule-recursively (first rules) (normalize-comp prog)))))