| blob | 9a0e24704c8fba8957fe94ac91dc71a1d598fa16 |
1 (define bank-1-used? #f)
3 (define (linearize-and-cleanup cfg)
5 (define bbs-vector (cfg->vector cfg))
7 (define todo '())
9 (define (add-todo bb)
10 (set! todo (cons bb todo)))
12 (define rev-code '())
14 (define (emit instr)
15 (set! rev-code (cons instr rev-code)))
17 (define (outside-bank-0? adr)
18 (if (and (> adr #x5F) (< adr #xF60)) ; not a special register
19 (begin (set! bank-1-used? #t) #t)
20 #f))
21 (define (emit-byte-oriented op file #!optional (d? #t) (w? #f))
22 ;; we might have to access the second bank
23 (emit (if (outside-bank-0? file)
24 (if d?
25 (list op (- file 96) (if w? 'w 'f) 'b)
26 (list op (- file 96) 'b))
27 (if d?
28 (list op file (if w? 'w 'f) 'a)
29 (list op file 'a)))))
30 (define (emit-bit-oriented op file bit)
31 (emit (if (outside-bank-0? file)
32 (list op (- file 96) bit 'b)
33 (list op file bit 'a))))
35 (define (movlw val)
36 (emit (list 'movlw val)))
37 (define (movwf adr)
38 (emit-byte-oriented 'movwf adr #f))
39 (define (movfw adr)
40 (emit-byte-oriented 'movf adr #t #t))
41 (define (movff src dst)
42 ;; anything over #x5f is in the second bank (at #x100)
43 (let ((src (if (outside-bank-0? src)
44 (+ src #xa0)
45 src))
46 (dst (if (outside-bank-0? dst)
47 (+ dst #xa0)
48 dst)))
49 (emit (list 'movff src dst))))
51 (define (clrf adr)
52 (emit-byte-oriented 'clrf adr #f))
53 (define (setf adr)
54 (emit-byte-oriented 'setf adr #f))
56 (define (incf adr)
57 (emit-byte-oriented 'incf adr))
58 (define (decf adr)
59 (emit-byte-oriented 'decf adr))
61 (define (addwf adr)
62 (emit-byte-oriented 'addwf adr))
63 (define (addwfc adr)
64 (emit-byte-oriented 'addwfc adr))
66 (define (subwf adr)
67 (emit-byte-oriented 'subwf adr))
68 (define (subwfb adr)
69 (emit-byte-oriented 'subwfb adr))
71 (define (mullw adr)
72 (emit (list 'mullw adr)))
73 (define (mulwf adr)
74 (emit-byte-oriented 'mulwf adr #f))
76 (define (andwf adr)
77 (emit-byte-oriented 'andwf adr))
78 (define (iorwf adr)
79 (emit-byte-oriented 'iorwf adr))
80 (define (xorwf adr)
81 (emit-byte-oriented 'xorwf adr))
83 (define (rlcf adr)
84 (emit-byte-oriented 'rlcf adr))
85 (define (rrcf adr)
86 (emit-byte-oriented 'rrcf adr))
88 (define (bcf adr bit)
89 (emit-bit-oriented 'bcf adr bit))
90 (define (bsf adr bit)
91 (emit-bit-oriented 'bsf adr bit))
92 (define (btg adr bit)
93 (emit-bit-oriented 'btg adr bit))
95 (define (comf adr)
96 (emit-byte-oriented 'comf adr))
98 (define (tblrd) ;; TODO support the different modes
99 (emit (list 'tblrd)))
101 (define (cpfseq adr)
102 (emit-byte-oriented 'cpfseq adr #f))
103 (define (cpfslt adr)
104 (emit-byte-oriented 'cpfslt adr #f))
105 (define (cpfsgt adr)
106 (emit-byte-oriented 'cpfsgt adr #f))
108 (define (bra-or-goto label)
109 (emit (list 'bra-or-goto label)))
110 (define (goto label)
111 (emit (list 'goto label)))
113 (define (rcall label)
114 (emit (list 'rcall label)))
116 (define (return)
117 (if (and #f (and (not (null? rev-code))
118 (eq? (caar rev-code) 'rcall)))
119 (let ((label (cadar rev-code)))
120 (set! rev-code (cdr rev-code))
121 (bra-or-goto label))
122 (emit (list 'return))))
124 (define (label lab)
125 (if (and #f (and (not (null? rev-code))
126 (eq? (caar rev-code) 'bra-or-goto)
127 (eq? (cadar rev-code) lab)))
128 (begin
129 (set! rev-code (cdr rev-code))
130 (label lab))
131 (emit (list 'label lab))))
133 (define (sleep)
134 (emit (list 'sleep)))
136 (define (move-reg src dst)
137 (cond ((= src dst))
138 ((= src WREG)
139 (movwf dst))
140 ((= dst WREG)
141 (movfw src))
142 (else
143 ;; (movfw src)
144 ;; (movwf dst)
145 ;; takes 2 cycles (as much as movfw src ; movwf dst), but takes
146 ;; only 1 instruction
147 (movff src dst))))
149 (define (bb-linearize bb)
150 (let ((label-num (bb-label-num bb)))
151 (let ((bb (vector-ref bbs-vector label-num)))
153 (define (move-lit n adr)
154 (cond ((= n 0)
155 (clrf adr))
156 ((= n #xff)
157 (setf adr))
158 (else
159 (movlw n)
160 (movwf adr))))
162 (define (dump-instr instr)
163 (cond ((call-instr? instr)
164 (let* ((def-proc (call-instr-def-proc instr))
165 (entry (def-procedure-entry def-proc)))
166 (if (bb? entry)
167 (begin
168 (add-todo entry)
169 (let ((label (bb-label entry)))
170 (rcall label)))
171 (rcall entry))))
172 ((return-instr? instr)
173 (return))
174 (else
175 (let ((src1 (instr-src1 instr))
176 (src2 (instr-src2 instr))
177 (dst (instr-dst instr)))
178 (if (and (or (not (byte-cell? dst))
179 (byte-cell-adr dst))
180 (or (not (byte-cell? src1))
181 (byte-cell-adr src1))
182 (or (not (byte-cell? src2))
183 (byte-cell-adr src2)))
185 (case (instr-id instr)
187 ((move)
188 (if (byte-lit? src1)
189 (let ((n (byte-lit-val src1))
190 (z (byte-cell-adr dst)))
191 (move-lit n z))
192 (let ((x (byte-cell-adr src1))
193 (z (byte-cell-adr dst)))
194 (move-reg x z))))
196 ((add addc sub subb)
197 (if (byte-lit? src2)
198 (let ((n (byte-lit-val src2))
199 (z (byte-cell-adr dst)))
200 (if (byte-lit? src1)
201 (move-lit (byte-lit-val src1) z)
202 (move-reg (byte-cell-adr src1) z))
203 (case (instr-id instr)
204 ((add) (cond ((= n 1) (incf z))
205 ((= n #xff) (decf z))
206 (else (movlw n)
207 (addwf z))))
208 ((addc) (movlw n) (addwfc z))
209 ((sub) (cond ((= n 1) (decf z))
210 ((= n #xff) (incf z))
211 (else (movlw n)
212 (subwf z))))
213 ((subb) (movlw n) (subwfb z))))
214 (let ((x (byte-cell-adr src1))
215 (y (byte-cell-adr src2))
216 (z (byte-cell-adr dst)))
217 (cond ((and (not (= x y))
218 (= y z)
219 (memq (instr-id instr)
220 '(add addc)))
221 ;; since this basically swaps the
222 ;; arguments, it can't be used for
223 ;; subtraction
224 (move-reg x WREG))
225 ((and (not (= x y))
226 (= y z))
227 ;; for subtraction, preserves argument
228 ;; order
229 (move-reg y WREG)
230 ;; this NEEDS to be done with movff, or
231 ;; else wreg will get clobbered and this
232 ;; won't work
233 (move-reg x z))
234 (else ;; TODO check if it could be merged with the previous case
235 (move-reg x z)
236 (move-reg y WREG)))
237 (case (instr-id instr)
238 ((add) (addwf z))
239 ((addc) (addwfc z))
240 ((sub) (subwf z))
241 ((subb) (subwfb z))
242 (else (error "..."))))))
244 ((mul) ; 8 by 8 multiplication
245 (if (byte-lit? src2)
246 ;; since multiplication is commutative, the
247 ;; arguments are set up so the second one will
248 ;; be a literal if the operator is applied on a
249 ;; literal and a variable
250 (let ((n (byte-lit-val src2)))
251 (if (byte-lit? src1)
252 (movlw (byte-lit-val src1))
253 (move-reg (byte-cell-adr src1) WREG))
254 ;; literal multiplication
255 (mullw n))
256 (let ((x (byte-cell-adr src1))
257 (y (byte-cell-adr src2)))
258 (move-reg x WREG)
259 (mulwf y))))
261 ((and ior xor)
262 (let ((x (if (byte-lit? src1)
263 (byte-lit-val src1)
264 (byte-cell-adr src1)))
265 (y (if (byte-lit? src2)
266 (byte-lit-val src2)
267 (byte-cell-adr src2)))
268 (z (byte-cell-adr dst)))
269 (cond ((byte-lit? src2)
270 (if (byte-lit? src1)
271 (move-lit x z)
272 (move-reg x z))
273 (movlw y))
274 ((and (not (= x y)) (= y z))
275 (move-reg x WREG))
276 (else
277 (move-reg x z)
278 (move-reg y WREG)))
279 (case (instr-id instr)
280 ((and) (andwf z))
281 ((ior) (iorwf z))
282 ((xor) (xorwf z))
283 (else (error "...")))))
285 ((shl shr)
286 (let ((x (if (byte-lit? src1)
287 (byte-lit-val src1)
288 (byte-cell-adr src1)))
289 (z (byte-cell-adr dst)))
290 (cond ((byte-lit? src1) (move-lit x z))
291 ((not (= x z)) (move-reg x z)))
292 (case (instr-id instr)
293 ((shl) (rlcf z))
294 ((shr) (rrcf z)))))
296 ((set clear toggle)
297 ;; bit operations
298 (if (not (byte-lit? src2))
299 (error "bit offset must be a literal"))
300 (let ((x (byte-cell-adr src1))
301 (y (byte-lit-val src2)))
302 (case (instr-id instr)
303 ((set) (bsf x y))
304 ((clear) (bcf x y))
305 ((toggle) (btg x y)))))
307 ((not)
308 (let ((z (byte-cell-adr dst)))
309 (if (byte-lit? src1)
310 (move-lit (byte-lit-val src1) z)
311 (move-reg (byte-cell-adr src1) z))
312 (comf z)))
314 ((tblrd)
315 (if (byte-lit? src1)
316 (move-lit (byte-lit-val src1) TBLPTRL)
317 (move-reg (byte-cell-adr src1) TBLPTRL))
318 (if (byte-lit? src2)
319 (move-lit (byte-lit-val src2) TBLPTRH)
320 (move-reg (byte-cell-adr src2) TBLPTRH))
321 ;; TODO the 5 high bits are not used for now
322 (tblrd))
324 ((goto)
325 (if (null? (bb-succs bb))
326 (error "I think you might have given me an empty source file."))
327 (let* ((succs (bb-succs bb))
328 (dest (car succs)))
329 (bra-or-goto (bb-label dest))
330 (add-todo dest)))
331 ((x==y x<y x>y)
332 (let* ((succs (bb-succs bb))
333 (dest-true (car succs))
334 (dest-false (cadr succs)))
336 (define (compare flip adr)
337 (case (instr-id instr)
338 ((x<y) (if flip (cpfsgt adr) (cpfslt adr)))
339 ((x>y) (if flip (cpfslt adr) (cpfsgt adr)))
340 (else (cpfseq adr)))
341 (bra-or-goto (bb-label dest-false))
342 (bra-or-goto (bb-label dest-true))
343 (add-todo dest-false)
344 (add-todo dest-true))
346 (cond ((byte-lit? src1)
347 (let ((n (byte-lit-val src1))
348 (y (byte-cell-adr src2)))
349 (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
350 (eq? (instr-id instr) 'x==y))
351 (special-compare-eq-lit n x)
352 (begin
353 (movlw n)
354 (compare #t y)))))
355 ((byte-lit? src2)
356 (let ((x (byte-cell-adr src1))
357 (n (byte-lit-val src2)))
358 (if #f #;(and (or (= n 0) (= n 1) (= n #xff))
359 (eq? (instr-id instr) 'x==y))
360 (special-compare-eq-lit n x)
361 (begin
362 (movlw n)
363 (compare #f x)))))
364 (else
365 (let ((x (byte-cell-adr src1))
366 (y (byte-cell-adr src2)))
367 (move-reg y WREG)
368 (compare #f x))))))
370 ((branch-table)
371 (let ((off (byte-cell-adr src1))) ; branch no TODO we can't have literals, we need the space to calculate the address
372 ;; precalculate the low byte of the PC
373 (movfw off)
374 (movff PCL off) ;; TODO at assembly, this can all be known statically
375 ;; we add 4 times the offset, since gotos are 4
376 ;; bytes long
377 (addwf off)
378 (addwf off)
379 (addwf off)
380 (addwf off)
381 ;; to compensate for the PC advancing while we calculate
382 (movlw 20)
383 (addwf off)
384 (clrf WREG)
385 (addwfc PCLATH) ; set PCH if we overflow
386 (movff off PCL) ; setting PCL moves PCLATH to PCH
388 ;; create the jump table
389 (for-each (lambda (bb)
390 (goto (bb-label bb))
391 (add-todo bb))
392 (bb-succs bb))))
394 (else
395 ;; ...
396 (emit (list (instr-id instr))))))))))
398 (if bb
399 (begin
400 (vector-set! bbs-vector label-num #f)
401 (label (bb-label bb))
402 (for-each dump-instr (reverse (bb-rev-instrs bb)))
403 (for-each add-todo (bb-succs bb)))))))
405 (let ((prog-label (asm-make-label 'PROG)))
406 (rcall prog-label)
407 (sleep)
408 (label prog-label))
410 (add-todo (vector-ref bbs-vector 0))
412 (let loop ()
413 (if (null? todo)
414 (reverse rev-code)
415 (let ((bb (car todo)))
416 (set! todo (cdr todo))
417 (bb-linearize bb)
418 (loop)))))
421 (define (assembler-gen filename cfg)
423 (define (gen instr)
424 (define (gen-1-arg)
425 ((eval (car instr)) (cadr instr)))
426 (define (gen-2-args)
427 ((eval (car instr)) (cadr instr) (caddr instr)))
428 (define (gen-3-args)
429 ((eval (car instr)) (cadr instr) (caddr instr) (cadddr instr)))
430 (case (car instr)
431 ((movlw mullw)
432 (gen-1-arg))
433 ((movff movwf clrf setf cpfseq cpfslt cpfsgt mulwf)
434 (gen-2-args))
435 ((incf decf addwf addwfc subwf subwfb andwf iorwf xorwf rlcf rrcf comf
436 bcf bsf btg movf)
437 (gen-3-args))
438 ((tblrd)
439 (tblrd*)) ;; TODO support the other modes
440 ((bra)
441 (bra (cadr instr)))
442 ((goto)
443 (goto (cadr instr)))
444 ((bra-or-goto)
445 (bra-or-goto (cadr instr)))
446 ((rcall)
447 (rcall-or-call (cadr instr)))
448 ((return)
449 (return))
450 ((label)
451 (asm-listing
452 (string-append (symbol->string (asm-label-id (cadr instr))) ":"))
453 (asm-label (cadr instr)))
454 ((sleep)
455 (sleep))
456 (else
457 (error "unknown instruction" instr))))
459 (asm-begin! 0 #f)
461 ;; (pretty-print cfg)
463 (let ((code (linearize-and-cleanup cfg)))
464 ;; (pretty-print code)
465 ;; if we would need a second bank, load the address for the second bank in BSR
466 (if bank-1-used?
467 (begin (gen (list 'movlw 1))
468 (gen (list 'movwf BSR 'a))))
469 (for-each gen code)))