compiler: bug: bad basic-block merge across end insn.

The bad situation reproduced as a miscompilation of some prof
forms at *opt-level* 5 or above.

The basic idea is that there is a situation like this

   prof t2
   ... profiled code here producing value in t8
   mov t2 t8
   end t2
   end t2

The code block produces a value in t8, which is copied into
t2, and executes the end instruction. This instruction does not
fall through to the next one but passes control back to the
prof instruction. The prof instruction then stores the result
value, which came from t2, back into the t2 register and
resumes the program at the end t2.

The first bad thing that happens is that the end instructions
get merged together into one basic block. The optimizer then
treats them without regard for the prof instruction, as if
they were a linear sequence. It looks like the register move

   mov t2 t8

is wasteful and so it eliminates it, rewriting the end instruction
to:

   end t8
   end t8

Of course, the second instruction is now wrong because prof is
still producing the result in t2.

To fix this without changing the instruction set, I'm introducing
another pseudo-op that represents end, called xend. This is
similar to jend, except that jend is regarded as an unconditional
branch whereas xend isn't.   The special thing about xend is
that a basic block in which it occcurs is marked as non-joinable.
It will not be joined with the following basic block.

* stdlib/asm.tl (xend): New alias opcode for end.

* stdlib/compiler.tl (comp-prof): Use xend to end prof fragment,
rather than plain end.

* stdlib/optimize.tl (basic-block): New slot, nojoin.
If true, block cannot be joined with next one.
(basic-blocks jump-ops): Add xend to list of jump ops,
so that a basic block will terminate on xend.
(basic-blocks link-graph): Set the nojoin flag on a
basic block which contains (and thus ends with) xend.
(basic-blocks local-liveness): Add xend to the case
in def-ref that handles end.
(basic-blocks (peephole, join-blocks)): Refuse to join
blocks marked nojoin.

* tests/019/comp-bugs.tl: New file with miscompiled
test case that was returning 42 instead of (42 0 0 0)
as a result of the wrong register's value being returned.

4 files changed, 18 insertions, 6 deletions

diff --git a/stdlib/asm.tl b/stdlib/asm.tl
index 96f3f9e8..139eab47 100644
--- a/stdlib/asm.tl
+++ b/stdlib/asm.tl
@@ -394,6 +394,8 @@
 
 (defopcode-alias jend end)
 
+(defopcode-alias xend end)
+
 (defopcode-derived op-prof prof auto op-end)
 
 (defopcode op-call call auto
diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl
index 78ee5f12..6fb7cae0 100644
--- a/stdlib/compiler.tl
+++ b/stdlib/compiler.tl
@@ -1599,7 +1599,7 @@
       (new (frag oreg
                  ^((prof ,oreg)
                    ,*bfrag.code
-                   (end ,bfrag.oreg))
+                   (xend ,bfrag.oreg))
                  bfrag.fvars bfrag.ffuns)))))
 
 (defun misleading-ref-check (frag env form)
diff --git a/stdlib/optimize.tl b/stdlib/optimize.tl
index 914df5b3..490653c9 100644
--- a/stdlib/optimize.tl
+++ b/stdlib/optimize.tl
@@ -39,6 +39,7 @@
     rlinks
     insns
     closer
+    nojoin
 
     (:method print (bl stream pretty-p)
        (put-string "#S" stream)
@@ -64,7 +65,7 @@
     tryjoin
     (:static start (gensym "start-"))
     (:static jump-ops '(jmp if ifq ifql close swtch ret abscsr
-                        uwprot catch block jend))
+                        uwprot catch block jend xend))
 
     (:postinit (bb)
       (let* ((insns (early-peephole (dedup-labels (cons bb.start bb.insns))))
@@ -146,7 +147,9 @@
         ((uwprot @clabel)
          (set bl.links (list [bb.hash clabel])))
         ((@(or abscsr ret jend) . @nil)
-         (set link-next nil)))
+         (set link-next nil))
+        ((xend . @nil)
+         (set bl.nojoin t)))
       (when (and nxbl link-next)
         (set bl.next nxbl)
         (pushnew nxbl bl.links))
@@ -200,7 +203,7 @@
                (let* ((li (liveness (cdr insns)))
                       (insn (car insns)))
                  (match-case insn
-                   ((@(or end jend prof) @reg)
+                   ((@(or end jend xend prof) @reg)
                     (refs li insn reg))
                    ((@(or apply call) @def . @refs)
                     (def-ref li insn def . refs))
@@ -230,7 +233,7 @@
                     (def li insn reg))
                    ((@op . @nil)
                     (caseq op
-                      ((end jend prof or apply call or gapply gcall mov if
+                      ((end jend xend prof or apply call or gapply gcall mov if
                         ifq ifql swtch block ret abscsr catch handle getv
                         getvb getfb getl1b getlx getf setl1 setlx bindv close)
                        (error `wrongly handled @insn instruction`))
@@ -481,7 +484,7 @@
   (whilet ((rescan (zap bb.rescan)))
     (whilet ((bl (pop bb.tryjoin)))
       (let ((nxbl bl.next))
-        (when (null (cdr nxbl.rlinks))
+        (unless (or bl.nojoin (cdr nxbl.rlinks))
           bb.(join-block bl nxbl)
           (set bb.recalc t)
           (when (memq nxbl bb.tryjoin)
@@ -527,6 +530,7 @@
                 (cond
                   ((and (eq bl.next nxbl)
                         (eq (car bl.links) nxbl)
+                        (null bl.nojoin)
                         (null (cdr bl.links))
                         (null (cdr nxbl.rlinks)))
                    bb.(join-block bl nxbl)
diff --git a/tests/019/comp-bugs.tl b/tests/019/comp-bugs.tl
new file mode 100644
index 00000000..c2cb2ad7
--- /dev/null
+++ b/tests/019/comp-bugs.tl
@@ -0,0 +1,6 @@
+(load "../common")
+
+(set *compile-test* t)
+
+(test
+  (prof (for ((i 42)) ((< i 42) i) ())) (42 0 0 0))