diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2018-07-09 22:29:19 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2018-07-09 22:29:19 -0700 |
| commit | 97fa49cc2c9c9c1452316acb003b4c7d104ed162 (patch) | |
| tree | 09c287105cd7dc27fa976a6bf63e8c81609124d1 /share | |
| parent | 8615311e3092283df22d5dd3b79564bf5e312e8b (diff) | |
| download | txr-97fa49cc2c9c9c1452316acb003b4c7d104ed162.tar.gz txr-97fa49cc2c9c9c1452316acb003b4c7d104ed162.tar.bz2 txr-97fa49cc2c9c9c1452316acb003b4c7d104ed162.zip | |
compiler: constant-fold if eql.
We put the ifql opcode to use for (if (eql ...) ...)
and (if (neql ...) ...) and also constant-fold the constant
cases, like we do for eq.
* share/txr/stdlib/compiler.tl (%test-funs-pos%): Add eql to
list.
(%test-funs-neg%): Add neql to list.
(%test-funs-ops%): New list of corresponding opcodes.
(%test-opcode%): New variable containing a relation function
from equality functions to assembler opcodes.
(compiler comp-ift): Don't hard code the opcode; look it up
from the test function using %test-opcode%.
Diffstat (limited to 'share')
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 13 |
1 files changed, 9 insertions, 4 deletions
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index 53508c32..be76f470 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -208,14 +208,18 @@ (defvarl %call-op% (relate '(apply usr:apply call) '(apply apply call))) -(defvarl %test-funs-pos% '(eq)) +(defvarl %test-funs-pos% '(eq eql)) -(defvarl %test-funs-neg% '(neq)) +(defvarl %test-funs-neg% '(neq neql)) + +(defvarl %test-funs-ops% '(ifq ifql)) (defvarl %test-funs% (append %test-funs-pos% %test-funs-neg%)) (defvarl %test-inv% (relate %test-funs-neg% %test-funs-pos%)) +(defvarl %test-opcode% (relate %test-funs-pos% %test-funs-ops%)) + (defvarl %block-using-funs% '(sys:capture-cont return* sys:abscond* match-fun eval load compile compile-file compile-toplevel)) @@ -498,7 +502,8 @@ (swap then else)) (if (and (constantp left) (constantp right)) me.(compile oreg env (if (call fun (eval left) (eval right)) then else)) - (let* ((le-oreg me.(alloc-treg)) + (let* ((opcode [%test-opcode% fun]) + (le-oreg me.(alloc-treg)) (ri-oreg me.(alloc-treg)) (lelse (gensym "l")) (lskip (gensym "l")) @@ -511,7 +516,7 @@ (new (frag oreg ^(,*le-frag.code ,*ri-frag.code - (ifq ,le-frag.oreg ,ri-frag.oreg ,lelse) + (,opcode ,le-frag.oreg ,ri-frag.oreg ,lelse) ,*th-frag.code ,*(maybe-mov oreg th-frag.oreg) (jmp ,lskip) |