diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2021-01-27 06:26:27 -0800 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2021-01-27 06:26:27 -0800 |
| commit | 781e27b5a11beb7341b8453c91bf18d1cc6ff741 (patch) | |
| tree | 93db9bc18c3d50044a03570bf84e8e8f07b57c09 | |
| parent | 62e1785a69a35e6df8bbee8c923c63b25ffd9f9a (diff) | |
| download | txr-781e27b5a11beb7341b8453c91bf18d1cc6ff741.tar.gz txr-781e27b5a11beb7341b8453c91bf18d1cc6ff741.tar.bz2 txr-781e27b5a11beb7341b8453c91bf18d1cc6ff741.zip | |
optimizer: syntactic sugar around rewrite.
* share/txr/stdlib/optimize.tl (rewrite-case): New macro,
combining rewrite, lambda and match-case.
(basic-blocks thread-jumps): Condense using rewrite-case,
and unfold some of the expressions into longer lines,
since everything has moved quite a bit to the left.
| -rw-r--r-- | share/txr/stdlib/optimize.tl | 90 |
1 files changed, 44 insertions, 46 deletions
diff --git a/share/txr/stdlib/optimize.tl b/share/txr/stdlib/optimize.tl index 537bceed..4cc82876 100644 --- a/share/txr/stdlib/optimize.tl +++ b/share/txr/stdlib/optimize.tl @@ -41,55 +41,53 @@ (:method get-insns (bb) [mappend bb.hash bb.labels]))) +(defmacro rewrite-case (sym list . cases) + ^(rewrite (lambda (,sym) + (match-case ,sym + ,*cases)) + ,list)) + (defmeth basic-blocks thread-jumps (bb) (dohash (label code bb.hash) (set [bb.hash label] - (rewrite (lambda (insns) - (match-case insns - (((jmp @jlabel) . @rest) - (let ((jinsns [bb.hash jlabel])) - (match-case jinsns - ((@(op eq jlabel) - (jmp @(require @jjlabel (neq jjlabel jlabel))) - . @nil) - ^((jmp ,jjlabel) ,*rest)) - (@jelse insns)))) - (((if @reg @jlabel) . @rest) - (let ((jinsns [bb.hash jlabel])) - (match-case jinsns - ((@(op eq jlabel) - (if @(op eq reg) - @(require @jjlabel (neq jjlabel jlabel))) - . @nil) - ^((if ,reg ,jjlabel) ,*rest)) - ((@(op eq jlabel) - (jmp @(require @jjlabel (neq jjlabel jlabel))) - . @nil) - ^((if ,reg ,jjlabel) ,*rest)) - (@jelse insns)))) - (((ifq @reg @creg @jlabel) . @rest) - (let ((jinsns [bb.hash jlabel])) - (match-case jinsns - ((@(op eq jlabel) - (ifq @(op eq reg) @(op eq creg) - @(require @jjlabel (neq jjlabel jlabel))) - . @nil) - ^((ifq ,reg ,creg ,jjlabel) ,*rest)) - ((@(op eq jlabel) - (jmp @(require @jjlabel (neq jjlabel jlabel))) - . @nil) - ^((ifq ,reg ,creg ,jjlabel) ,*rest)) - (@jelse insns)))) - (((close @reg @nargs @jlabel . @cargs) . @rest) - (let ((jinsns [bb.hash jlabel])) - (match-case jinsns - ((@(op eq jlabel) - (jmp @(require @jjlabel (neq jjlabel jlabel))) - . @nil) - ^((close ,reg ,nargs ,jjlabel ,*cargs) ,*rest)) - (@jelse insns)))) - (@else insns))) - code)))) + (rewrite-case insns code + (((jmp @jlabel) . @rest) + (let ((jinsns [bb.hash jlabel])) + (match-case jinsns + ((@(op eq jlabel) + (jmp @(require @jjlabel (neq jjlabel jlabel))) . @nil) + ^((jmp ,jjlabel) ,*rest)) + (@jelse insns)))) + (((if @reg @jlabel) . @rest) + (let ((jinsns [bb.hash jlabel])) + (match-case jinsns + ((@(op eq jlabel) + (if @(op eq reg) + @(require @jjlabel (neq jjlabel jlabel))) . @nil) + ^((if ,reg ,jjlabel) ,*rest)) + ((@(op eq jlabel) + (jmp @(require @jjlabel (neq jjlabel jlabel))) . @nil) + ^((if ,reg ,jjlabel) ,*rest)) + (@jelse insns)))) + (((ifq @reg @creg @jlabel) . @rest) + (let ((jinsns [bb.hash jlabel])) + (match-case jinsns + ((@(op eq jlabel) + (ifq @(op eq reg) @(op eq creg) + @(require @jjlabel (neq jjlabel jlabel))) . @nil) + ^((ifq ,reg ,creg ,jjlabel) ,*rest)) + ((@(op eq jlabel) + (jmp @(require @jjlabel (neq jjlabel jlabel))) . @nil) + ^((ifq ,reg ,creg ,jjlabel) ,*rest)) + (@jelse insns)))) + (((close @reg @nargs @jlabel . @cargs) . @rest) + (let ((jinsns [bb.hash jlabel])) + (match-case jinsns + ((@(op eq jlabel) + (jmp @(require @jjlabel (neq jjlabel jlabel))) . @nil) + ^((close ,reg ,nargs ,jjlabel ,*cargs) ,*rest)) + (@jelse insns)))) + (@else insns))))) (defun rewrite (fun list) (build |