-
Notifications
You must be signed in to change notification settings - Fork 1
/
munch-syntax.scm
197 lines (166 loc) · 6.38 KB
/
munch-syntax.scm
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
190
191
192
193
194
195
196
(import-for-syntax matchable)
(import-for-syntax srfi-1)
;; convenience constructors (used in pattern match rules)
(define-syntax define-munch-rules
(lambda (e r c)
(let ((%let* (r 'let*))
(%let (r 'let))
(%if (r 'if))
(%cond (r 'cond))
(%else (r 'else))
(%define (r 'define))
(%match (r 'match))
(%gensym (r 'gensym))
(%block (r 'block))
(%tree (r 'tree))
(%t1 (gensym 't))
(%mc-block-append (r 'mc-block-append))
(%mc-context-allocate-vreg (r 'mc-context-allocate-vreg))
(%mc-block-cxt (r 'mc-block-cxt)))
(define renamed '())
(define (rename name)
(cond
((assq name renamed)
=> cdr)
(else
(let ((x (gensym)))
(set! renamed (cons (cons name x) renamed))
x))))
;; select-names
;;
;; Find names (which are bound to nodes by 'match) which need to be expanded next by the maximal-munch algorithm
;;
;; (add (i32 x) op2)
;; => (op2)
(define (select-names pat)
(match pat
((? symbol? x)
(list x))
((or ('const _ _) ('mode _) ('op _) ('label _) ('temp _))
'())
((opcode operand* ...)
(apply append (map select-names operand*)))))
;; compile-pattern
;;
;; Transform high-level patterns into low-level 'match patterns
;;
;; (add (i32 x) op2)
;; => ($ tree-instr 'add ('mode 'i32) (? i32? x) (? symbol? g67))
;;
(define (compile-pattern pat)
(define (walk pat)
(match pat
;; assign
(('assign ('temp x) op)
`($ tree-instr 'assign _ (? symbol? ,x) ,(walk op) _ _ _ _ _))
;; binops
(('add mode op1 op2)
`($ tree-instr 'add ',(walk mode) ,(walk op1) ,(walk op2) _ _ _ _ _))
(('sub mode op1 op2)
`($ tree-instr 'sub ',(walk mode) ,(walk op1) ,(walk op2) _ _ _ _ _))
(('and mode op1 op2)
`($ tree-instr 'and ',(walk mode) ,(walk op1) ,(walk op2) _ _ _ _ _))
(('ior mode op1 op2)
`($ tree-instr 'ior ',(walk mode) ,(walk op1) ,(walk op2) _ _ _ _ _))
(('xor mode op1 op2)
`($ tree-instr 'xor ',(walk mode) ,(walk op1) ,(walk op2) _ _ _ _ _))
(('shl mode op1 op2)
`($ tree-instr 'shl ',(walk mode) ,(walk op1) ,(walk op2) _ _ _ _ _))
(('shr mode op1 op2)
`($ tree-instr 'shr ',(walk mode) ,(walk op1) ,(walk op2) _ _ _ _ _))
;; load
(('load mode addr)
`($ tree-instr 'load ',(walk mode) ,(walk addr) _ _ _ _ _ _))
;; store
(('store mode value addr)
`($ tree-instr 'store ',(walk mode) ,(walk value) ,(walk addr) _ _ _ _ _))
;; brc
(('brc cond label1 label2)
`($ tree-instr 'brc _ ,(walk cond) ,(walk label1) ,(walk label2) _ _ _ _))
;; br
(('br label)
`($ tree-instr 'br _ ,(walk label) _ _ _ _ _ _))
;; cmp
(('cmp mode ('op test) op1 op2)
`($ tree-instr 'cmp ',(walk mode) ',test ,(walk op1) ,(walk op2) _ _ _ _))
;; atoms
(('const size x)
`($ tree-constant ',size ,x))
(('label x)
`($ tree-label ,x))
(('temp x)
`($ tree-temp ,x))
((? symbol? x) (rename x))
;; mode
(('mode x) x)
;;(_ (print pat))
))
(walk pat))
(define (gen-bindings arch bindings)
(let ((function-name (string->symbol (format "munch-~s" arch))))
(match bindings
(() '())
((expr . rest)
(cons `(,expr (,function-name ,%block ,(rename expr))) (gen-bindings arch rest))))))
(define (parse-temp-cls out)
(match out
(('temps t* ...) t*)
(else (assert-not-reached))))
(define (parse-out-cls out)
(match out
(('out x) x)
(('out) #f)
(else (assert-not-reached))))
(define (gen-code arch pat temps out tmpl*)
(let* ((nodes-to-expand (select-names pat))
(pat-compiled (compile-pattern pat))
(bindings
(append
;; Bind names to expanded nodes
(gen-bindings arch nodes-to-expand)
(cond
;; bind the name 'out' to a gensym if this production requires a return value (in which case out != #f)
;; AND the user-specified return value is not already listed in nodes-to-expand.
((and out (not (memq out nodes-to-expand)))
`((,out (,%mc-context-allocate-vreg (,%mc-block-cxt ,%block) (,%gensym 't)))))
(else '()))
;; bind temps to unique symbols (remembering not to bind 'out again if it is declared as a temp)
(map (lambda (temp)
`(,temp (,%mc-context-allocate-vreg (,%mc-block-cxt ,%block) (,%gensym 't))))
(lset-difference eq? temps (list out))))))
`(,pat-compiled
(,%let* ,bindings
(arch-emit-code ,arch ,%block ,@tmpl*)
,out))))
(define (compile arch rule)
(match rule
((pat temp-cls out-cls (tmpl* ...))
(gen-code
arch
pat
(parse-temp-cls temp-cls)
(parse-out-cls out-cls)
tmpl*))))
(define (compile-rules arch rule*)
(reverse
(fold (lambda (rule x)
(cons (compile arch rule) x))
'()
rule*)))
(match e
(('define-munch-rules arch rule* ...)
(let* ((rule-compiled* (compile-rules arch rule*))
(function-name (string->symbol (format "munch-~s" arch))))
;; (pretty-print
;; `(,%define (,function-name ,%block ,%tree)
;; (,%match ,%tree
;; (($ tree-temp ,%t1)
;; (,%mc-context-allocate-vreg (,%mc-block-cxt ,%block) ,%t1))
;; ,@rule-compiled*
;; (_ (tree-instr-print ,%tree (current-output-port)) (error "no matching pattern")))))
`(,%define (,function-name ,%block ,%tree)
(,%match ,%tree
(($ tree-temp ,%t1)
(,%mc-context-allocate-vreg (,%mc-block-cxt ,%block) ,%t1))
,@rule-compiled*
(_ (tree-instr-print ,%tree (current-output-port)) (error "no matching pattern"))))))))))