1
#| peephole.jl -- peephole optimizer for rep assembly code
3
$Id: peephole.jl,v 1.30 2000/11/21 21:28:24 jsh Exp $
5
Copyright (C) 1999, 2000 John Harper <john@dcs.warwick.ac.uk>
7
This file is part of librep.
9
librep is free software; you can redistribute it and/or modify it
10
under the terms of the GNU General Public License as published by
11
the Free Software Foundation; either version 2, or (at your option)
14
librep is distributed in the hope that it will be useful, but
15
WITHOUT ANY WARRANTY; without even the implied warranty of
16
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17
GNU General Public License for more details.
19
You should have received a copy of the GNU General Public License
20
along with Jade; see the file COPYING. If not, write to
21
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
24
;; Most of the optimisation patterns in the peephole optimiser were
25
;; lifted from jwz's byte-optimize.el (XEmacs)
27
(declare (unsafe-for-call/cc))
29
(define-structure rep.vm.peephole
31
(export peephole-optimizer)
38
;; c{dd..d}r; car --> ca{dd..d}r
39
;; c{dd..d}r; cdr --> cd{dd..d}r
41
;; shift the instruction window
44
(setq point (cdr point))
47
(setq insn2 (nth 3 point))))
52
(setq insn0 (nth 1 point))
53
(setq insn1 (nth 2 point))
54
(setq insn2 (nth 3 point))))
56
;; delete the first instruction in the window
59
(rplacd point (nthcdr 2 point))
62
(setq insn2 (nth 3 point))))
64
;; delete the second instruction in the window
67
(rplacd (cdr point) (nthcdr 3 point))
69
(setq insn2 (nth 3 point))))
71
;; delete the third instruction in the window
74
(rplacd (nthcdr 2 point) (nthcdr 4 point))
75
(setq insn2 (nth 3 point))))
77
;; delete the first two instructions in the window
80
(rplacd point (nthcdr 3 point))
82
(setq insn1 (nth 2 point))
83
(setq insn2 (nth 3 point))))
85
;; delete the second two instructions in the window
88
(rplacd (cdr point) (nthcdr 4 point))
89
(setq insn1 (nth 2 point))
90
(setq insn2 (nth 3 point))))
92
;; delete all instructions in the window
93
(defmacro del-0-1-2 ()
95
(rplacd point (nthcdr 4 point))
100
`(format standard-error "before: [%S %S %S]\n"
101
(nth 1 point) (nth 2 point) (nth 3 point)))
103
`(format standard-error "after: [%S %S %S]\n"
104
(nth 1 point) (nth 2 point) (nth 3 point)))
106
;; run the optimiser over CODE-STRING, modifying and returning it
107
;; returns (CODE . EXTRA-STACK)
108
(defun peephole-optimizer (code-string)
111
point insn0 insn1 insn2 tem)
112
;; add an extra cons cell so we can always refer to the
113
;; cdr of the intsruction _before_ insn0, this makes it
114
;; easy to delete instructions
115
(setq code-string (cons 'start code-string))
117
(setq keep-going nil)
118
(setq point code-string)
121
;;(format standard-error "iter: %S\n\n" code-string)
123
;; <side-effect-free w/ stack+1>; pop --> <deleted>
124
;; <side-effect-free w/ stack+0>; pop --> pop
125
;; <side-effect-free w/ stack-1>; pop --> pop; pop
126
((and (eq (car insn1) 'pop)
127
(memq (car insn0) byte-side-effect-free-insns))
128
(setq tem (aref byte-insn-stack-delta (bytecode-ref (car insn0))))
138
(setq keep-going t))))
140
;; {push,dup}; setn #X; refn #X
141
;; --> {push,dup}; setn #X; {push, dup}
142
;; {push,dup}; bind X; refn #0
143
;; --> {push,dup}; bind X; {push, dup}
144
;; {push,dup}; slot-set #X; slot-ref #X
145
;; --> {push,dup}; slot-set #X; {push, dup}
146
((and (or (and (eq (car insn1) 'setn) (eq (car insn2) 'refn)
147
(eq (cadr insn1) (cadr insn2)))
148
(and (eq (car insn1) 'bind) (eq (car insn2) 'refn)
150
(and (eq (car insn1) 'slot-set) (eq (car insn2) 'slot-ref)
151
(eq (cadr insn1) (cadr insn2))))
152
(or (eq (car insn0) 'dup) (eq (car insn0) 'push)))
153
(rplaca insn2 (car insn0))
154
(rplacd insn2 (cdr insn0))
157
;; setn #X; refn #X --> dup; setn #X
158
;; bind; refn #0 --> dup; bind
159
;; slot-set #X; slot-ref #X --> dup; slot-set #X
160
((or (and (eq (car insn0) 'setn)
161
(eq (car insn1) 'refn)
162
(eq (cadr insn0) (cadr insn1)))
163
(and (eq (car insn0) 'bind)
164
(eq (car insn1) 'refn)
165
(eql (cadr insn1) 0))
166
(and (eq (car insn0) 'slot-set)
167
(eq (car insn1) 'slot-ref)
168
(eq (cadr insn0) (cadr insn1))))
169
(rplaca insn1 (car insn0))
170
(rplacd insn1 (cdr insn0))
173
;; this might require extra stack space
177
;; dup; {<varset>,<varbind>} X; pop --> {<varset>,<varbind>} X
178
((and (eq (car insn0) 'dup)
179
(or (memq (car insn1) byte-varset-insns)
180
(memq (car insn1) byte-varbind-insns))
181
(eq (car insn2) 'pop))
182
(rplaca insn2 (car insn1))
183
(rplacd insn2 (cdr insn1))
187
;; <varref> X; <varref> X --> <varref> X; dup
188
((and (memq (car insn0) byte-varref-insns)
189
(eq (car insn1) (car insn0))
190
(eq (cadr insn0) (cadr insn1)))
195
;; <varref> X; <varset> X --> deleted
196
((or (and (eq (car insn0) 'refn)
197
(eq (car insn1) 'setn)
198
(eql (cadr insn0) (cadr insn1)))
199
(and (eq (car insn0) 'refg)
200
(eq (car insn1) 'setg)
201
(eq (cadr insn0) (cadr insn1)))
202
(and (eq (car insn0) 'slot-ref)
203
(eq (car insn1) 'slot-set)
204
(eq (cadr insn0) (cadr insn1))))
209
((and (memq (car insn0) '(car cdr))
210
(memq (car insn1) '(car cdr)))
211
(rplaca insn1 (if (eq (car insn0) 'car)
212
(if (eq (car insn1) 'car) 'caar 'cdar)
213
(if (eq (car insn1) 'car) 'cadr 'cddr)))
217
;; test-scm; scm-test --> deleted
218
;; test-scm-f; scm-test --> deleted
219
;; [ these are only possible because scm-test is only used
220
;; for `cond' tests, not for its actual value ]
221
((and (memq (car insn0) '(test-scm test-scm-f))
222
(eq (car insn1) 'scm-test))
226
;; push 1; sub --> dec
227
;; push -1; sub --> inc
228
;; push 1; add --> inc
229
;; push -1; add --> dec
230
;; [ XXX these and more should be handled at a higher level ]
231
((and (eq (car insn0) 'push)
232
(memq (car insn1) '(sub add))
233
(memql (cadr insn0) '(1 -1)))
234
(let ((new (if (eql (cadr insn0) 1)
235
(if (eq (car insn1) 'sub) 'dec 'inc)
236
(if (eq (car insn1) 'sub) 'inc 'dec))))
239
(setq keep-going t)))
241
;; push 0; {add,sub} --> <deleted>
242
((and (equal insn0 '(push 0)) (memq (car insn1) '(add sub)))
246
;; push 0; num-eq --> zerop
247
((and (equal insn0 '(push 0)) (eq (car insn1) 'num-eq))
248
(rplaca insn1 'zerop)
252
;; zerop; not --> not-zero-p
253
((and (eq (car insn0) 'zerop) (eq (car insn1) 'not))
254
(rplaca insn1 'not-zero-p)
259
((and (eq (car insn0) 'jmp) (eq (cadr insn0) insn1))
263
;; {jn,jt} X; X: --> pop; X:
264
((and (memq (car insn0) '(jn jt)) (eq (cadr insn0) insn1))
269
;; {jpt,jpn} X; pop --> {jt,jn} X
270
((and (memq (car insn0) '(jpt jpn)) (eq (car insn1) 'pop))
271
(rplaca insn0 (if (eq (car insn0) 'jpt) 'jt 'jn))
275
;; not; {jn,jt} X --> {jt,jn} X
276
((and (eq (car insn0) 'not)
277
(memq (car insn1) '(jn jt)))
278
(rplaca insn1 (if (eq (car insn1) 'jn) 'jt 'jn))
282
;; jt X; (push ()) --> jpt X
283
((and (eq (car insn0) 'jt) (equal insn1 '(push ())))
288
;; {jn,jt} X; jmp Y; X: --> {jt,jn} Y; X:
289
((and (memq (car insn0) '(jn jt))
290
(eq (car insn1) 'jmp)
291
(eq (cadr insn0) insn2))
292
(rplaca insn1 (if (eq (car insn0) 'jn) 'jt 'jn))
296
;; (push X); <cond. jump> X; --> whatever
297
((and (eq (car insn0) 'push)
298
(memq (car insn1) byte-conditional-jmp-insns))
300
;; only way to get a nil constant is through `(push ())'
301
((is-nil (equal insn0 '(push ())))
303
(cond ((or (and is-nil (eq (car insn1) 'jn))
304
(and is-t (eq (car insn1) 'jt))
305
(and is-nil (eq (car insn1) 'jpn))
306
(and is-t (eq (car insn1) 'jpt)))
307
;; nil; jn X --> jmp X
309
;; nil; jpn X --> jmp X
310
;; t; jpt X --> jmp X
313
((or (and is-nil (eq (car insn1) 'jt))
314
(and is-t (eq (car insn1) 'jn))
315
(and is-t (eq (car insn1) 'jnp))
316
(and is-nil (eq (car insn1) 'jtp)))
317
;; nil; jt X --> <deleted>
318
;; t; jn X --> <deleted>
319
;; t; jnp X --> <deleted>
320
;; nil; jtp X --> <deleted>
322
((or (and is-nil (eq (car insn1) 'jnp))
323
(and is-t (eq (car insn1) 'jtp)))
324
;; nil; jnp X --> nil; jmp X
325
;; t; jtp X --> t; jmp X
327
((or (and is-t (eq (car insn1) 'jpn))
328
(and is-nil (eq (car insn1) 'jpt)))
330
;; nil; jpt X --> nil
332
(t (error "Unhandled contional jump case")))
333
(setq keep-going t)))
335
;; <varref-and-error-free-op>; unbind ---> unbind; op
336
((and (eq (car insn1) 'unbind)
337
(memq (car insn0) byte-varref-free-insns))
341
(rplaca insn0 (car insn1))
342
(rplacd insn0 (cdr insn1))
345
(setq keep-going t)))
347
;; <varbind> X; unbind --> pop; unbind
348
((and (memq (car insn0) byte-varbind-insns)
349
(eq (car insn1) 'unbind))
354
;; init-bind; unbind --> deleted
355
((and (eq (car insn0) 'init-bind) (eq (car insn1) 'unbind))
359
;; init-bind; {return,unbindall} --> {return,unbindall}
360
((and (eq (car insn0) 'init-bind)
361
(memq (car insn1) '(return unbindall)))
365
;; unbind; return --> return
366
((and (eq (car insn0) 'unbind) (eq (car insn1) 'return))
370
;; <varref> X; dup... ; <varref> X --> <varref> X; dup...; dup
371
((and (memq (car insn0) byte-varref-insns)
372
(eq (car insn1) 'dup))
374
((tem (nthcdr 2 point)))
375
(while (eq (car (car tem)) 'dup)
376
(setq tem (cdr tem)))
377
(when (equal (car tem) insn0)
378
(rplaca (car tem) 'dup)
379
(rplacd (car tem) nil)
380
(setq keep-going t))))
382
;; X: Y: --> X: [s/X/Y/]
383
((and (symbolp insn0) (symbolp insn1))
384
(let loop ((rest (cdr code-string)))
386
(when (and (eq (cadar rest) insn1)
387
(or (memq (caar rest) byte-jmp-insns)
388
(eq (caar rest) 'push-label)))
389
(rplaca (cdar rest) insn0))
394
;; [unused] X: --> deleted
395
((and (symbolp insn0)
396
(let loop ((rest (cdr code-string)))
397
(cond ((null rest) t)
398
((and (eq (cadar rest) insn0)
399
(or (memq (caar rest) byte-jmp-insns)
400
(eq (caar rest) 'push-label))) nil)
401
(t (loop (cdr rest))))))
405
;; jmp X; ... Y: --> jmp X; Y:
406
;; return; ... Y: --> return; Y:
407
((and (memq (car insn0) '(jmp ejmp return))
408
insn1 (not (symbolp insn1)))
409
(setq tem (nthcdr 2 point))
410
(while (and tem (not (symbolp (car tem))))
411
(setq tem (cdr tem)))
412
(unless (eq tem (nthcdr 2 point))
413
(rplacd (cdr point) tem)
415
(setq keep-going t)))
417
;; j* X; ... X: jmp Y --> j* Y; ... X: jmp Y
418
((and (memq (car insn0) byte-jmp-insns)
419
(setq tem (or (memq (cadr insn0) (cdr code-string))
420
(error "Can't find jump destination: %s, %s"
421
insn0 (cdr code-string))))
422
(setq tem (car (cdr tem)))
424
(not (eq (cadr insn0) (cadr tem))))
425
(rplacd insn0 (cdr tem))
428
;; jmp X; ... X: return --> return; ... X: return
429
((and (eq (car insn0) 'jmp)
430
(setq tem (or (memq (cadr insn0) (cdr code-string))
431
(error "Can't find jump destination: %s, %s"
432
insn0 (cdr code-string))))
433
(setq tem (car (cdr tem)))
434
(eq (car tem) 'return))
435
(rplaca insn0 'return)
439
;; {jnp,jtp} X; ... X: <cond. jmp> Y --> whatever
440
((and (memq (car insn0) '(jnp jtp))
441
(setq tem (cdr (or (memq (cadr insn0) (cdr code-string))
442
(error "Can't find jump destination: %s, %s"
443
insn0 (cdr code-string)))))
445
(memq (car (car tem)) byte-conditional-jmp-insns))
449
(if (eq (car insn0) 'jtp)
451
((memq (car jmp) '(jpt jt))
452
;; jtp X; ... X: jpt Y --> jt Y; ...
453
;; jtp X; ... X: jt Y --> jt Y; ...
456
;; jtp X; ... X: jpn Y --> jpt Z; ... X: jpn Y; Z:
458
(setq need-new-label t))
459
((memq (car jmp) '(jn jnp))
460
;; jtp X; ... X: jn Y --> jt Z; ... X: jpn Y; Z:
461
;; jtp X; ... X: jnp Y --> jt Z; ... X: jpn Y; Z:
463
(setq need-new-label t))
465
;; jtp X; ... X: jtp Y --> jtp Y; ...
466
(rplaca insn0 'jtp)))
469
;; jnp X; ... X: jpt Y --> jn Z; ... X: jpt Y; Z:
471
(setq need-new-label t))
472
((memq (car jmp) '(jpn jn))
473
;; jnp X; ... X: jpn Y --> jn Y ...
474
;; jnp X; ... X: jn Y --> jn Y ...
476
((memq (car jmp) '(jt jtp))
477
;; jnp X; ... X: jt Y --> jn Z; ... X: jt Y; Z:
478
;; jnp X; ... X: jtp Y --> jn Z; ... X: jt Y; Z:
480
(setq need-new-label t))
482
;; jnp X; ... X: jnp Y --> jnp Y ...
483
(rplaca insn0 'jnp))))
484
(if (not need-new-label)
485
(rplaca (cdr insn0) (cadr jmp))
486
;; add label `Z:' following the second jump
487
(let ((label (cons (gensym) (cdr tem))))
488
(rplaca (cdr insn0) (car label))
490
(setq keep-going t)))
492
;; {jpt,jpn} X; jmp Y; X: --> {jnp,jtp} Y; X:
493
;; {jtp,jnp} X; jmp Y; X: --> {jpn,jpt} Y; X:
494
((and (eq (car insn1) 'jmp)
495
(memq (car insn0) '(jpt jpn jtp jnp))
496
(eq (cadr insn0) insn2))
497
(rplaca insn1 (case (car insn0)
505
;; <const>; jmp X; ... X: <cond. jmp> Y --> whatever
507
;; [ this should be handled already, by (1) changing the
508
;; first jump, then by (2) dereferencing the constant ]
510
;; jmp X: Y: ... X: <cond. jmp> Y --> ???
513
;; shift in the next instruction
516
;; now do one last pass, looking for simple things
517
(setq point code-string)
521
;; push X; {<varset>,<varbind>} Y; push X
522
;; --> push X; dup; {<varset>,<varbind>} Y
523
((and (eq (car insn0) 'push)
524
(or (memq (car insn1) byte-varset-insns)
525
(memq (car insn1) byte-varbind-insns))
527
(rplaca insn2 (car insn1))
528
(rplacd insn2 (cdr insn1))
534
;; push X; {dup,push X}... --> push X; dup...
535
;; <varref> X; {dup,<varref> X}... --> <varref> X; dup...
536
((or (eq (car insn0) 'push)
537
(memq (car insn0) byte-varref-insns))
538
(setq tem (nthcdr 2 point))
539
(while (or (eq (caar tem) 'dup)
540
(equal (car tem) insn0))
541
(rplaca (car tem) 'dup)
542
(rplacd (car tem) nil)
543
(setq tem (cdr tem)))))
546
;; drop the extra cons we added
547
(cons (cdr code-string) extra-stack))))
added
removed
lisp/rep/vm/peephole.jl
