From bbb60b690e5a7dc696a766d500a8c36e62c53eb8 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Sun, 28 Feb 2021 09:49:28 -0800
Subject: compiler: avoid invalid if d-reg optimization.

We cannot assume that a d register is has a non-nil value.
This is because d registers are exploited in the
implementation of load-time: the result of a load-time form is
stored by mutating a d register, and the value could be nil.

Since we still want to be able to assume that d registers
are non-nil, what we can do is just avoid that assumption for
those d regisers that are used for load-time values.

* share/txr/stdlib/compiler.tl (struct compiler): When
constructing basic-blocks, pass a new constructor argument:
the list of load-time d-regs. This is easily obtained by
mapping the load-time frags to their oreg slots, which are
those d-regs.

* share/txr/stdlib/optimize.tl (struct basic-blocks): New
slot and BOA constructor argument, lt-dregs.
(basic-blocks thread-jumps-block): Add a require to the
pattern (if (d @reg) @jlabel), that the register must not
be one of the load-time d-regs.
---
 share/txr/stdlib/compiler.tl | 3 ++-
 share/txr/stdlib/optimize.tl | 7 +++++--
 2 files changed, 7 insertions(+), 3 deletions(-)

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index f8b3469e..59050ff5 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -1502,7 +1502,8 @@
              (new (frag dreg nil))))))))
 
 (defmeth compiler optimize (me insns)
-  (let* ((bb (new (basic-blocks insns))))
+  (let* ((lt-dregs (mapcar .oreg me.lt-frags))
+         (bb (new (basic-blocks insns lt-dregs))))
     bb.(calc-liveness)
     bb.(peephole)
     bb.(thread-jumps)
diff --git a/share/txr/stdlib/optimize.tl b/share/txr/stdlib/optimize.tl
index a2054ca3..fcaece3b 100644
--- a/share/txr/stdlib/optimize.tl
+++ b/share/txr/stdlib/optimize.tl
@@ -37,8 +37,9 @@
     links
     insns)
 
-  (defstruct (basic-blocks insns) nil
+  (defstruct (basic-blocks insns lt-dregs) nil
     insns
+    lt-dregs
     root
     (hash (hash))
     (li-hash (hash :eq-based))
@@ -257,7 +258,9 @@
     (while* (nequal ninsn insn)
       (set insn ninsn
            ninsn (match-case insn
-                   ((if (d @reg) @jlabel) nil)
+                   (@(require (if @(as reg (d @reg)) @jlabel)
+                              (not (memqual reg bb.lt-dregs)))
+                    nil)
                    ((if (t 0) @jlabel)
                     ^(jmp ,jlabel))
                    ((jmp @jlabel)
-- 
cgit v1.2.3