diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2018-04-18 06:18:02 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2018-04-18 06:18:02 -0700 |
| commit | 93cbd81f0fb5242bb93062848826bf5b6b5e9d46 (patch) | |
| tree | 06949b66eba3b6e0667b6ba652e96292b1f677c2 /share | |
| parent | bfc81fe0cb680d95ae8fc91ec94562d2df6e12e4 (diff) | |
| download | txr-93cbd81f0fb5242bb93062848826bf5b6b5e9d46.tar.gz txr-93cbd81f0fb5242bb93062848826bf5b6b5e9d46.tar.bz2 txr-93cbd81f0fb5242bb93062848826bf5b6b5e9d46.zip | |
compiler: de-duplicate switch.
* share/txr/stdlib/compiler.tl (compiler comp-switch):
Identify duplicate cases and don't generate code for these;
patch their table entries to point to one case.
The case macros generate such code when the keys are
integers, and multiple integer keys are associated
with the same case: (caseq x ((1 2 3 4 5) ...) ((6 7) ...)).
Diffstat (limited to 'share')
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 29 |
1 files changed, 18 insertions, 11 deletions
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index 8b705835..5d68e0f5 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -480,21 +480,28 @@ (clabels (mapcar (ret (gensym "l")) cases)) (treg me.(maybe-alloc-treg oreg)) (ifrag me.(compile treg env idx-form)) + (seen (unless shared (hash :eql-based))) last-cfrag (cfrags (collect-each ((cs cases) (lb clabels) (i (range 1))) - (let ((cfrag me.(comp-progn oreg env cs))) - (when (eq i ncases) - (set last-cfrag cfrag)) - (new (frag oreg - ^(,lb - ,*cfrag.code - ,*(unless shared - ^(,*(maybe-mov oreg cfrag.oreg) - ,*(unless (= i ncases) - ^((jmp ,lend)))))) - cfrag.fvars cfrag.ffuns)))))) + (iflet ((seen-lb (and seen [seen cs]))) + (progn + (set [clabels (pred i)] seen-lb) + (new (frag oreg nil))) + (let ((cfrag me.(comp-progn oreg env cs))) + (when (eq i ncases) + (set last-cfrag cfrag)) + (unless shared + (set [seen cs] lb)) + (new (frag oreg + ^(,lb + ,*cfrag.code + ,*(unless shared + ^(,*(maybe-mov oreg cfrag.oreg) + ,*(unless (= i ncases) + ^((jmp ,lend)))))) + cfrag.fvars cfrag.ffuns))))))) me.(maybe-free-treg treg oreg) (new (frag oreg ^(,*ifrag.code |