compiler: catch bugfix.

Commit a051f353e8627b03ebf7748a293c2e57d1bfa04d tried to fix
an aspect of this problem. I ran into an issue where the try
code produced a D register as its output, and this was
clobbered by the catch code.  In fact, the catch code simply
must not clobber the try fragment's output register. No matter
what register that is, it is not safe. A writable T register
could hold a variable.

For instance, this infinitely looping code is miscompiled
such that it terminates:

  (let ((x 42))
    (while (eql x 42)
      (catch
        (progn (throw 'foo)
               x)
        (foo () 0))))

When the exception is caught by the (foo () 0) clause
x is overwritten with that 0 value.

The variable x is assigned to a register like t13,
and since the progn form returns x as it value, it
compiles to a fragment (tfrag) which indicates t13
as its output register.

The catch code wrongly borrows ohis as its own output
register, placing the 0 value into it.

* stdlib/compiler.tl (compiler comp-catch): Get rid of the
coreg local variable, replacing all its uses with oreg.

1 files changed, 7 insertions, 8 deletions

diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl
index 69696b15..7fea5dcd 100644
--- a/stdlib/compiler.tl
+++ b/stdlib/compiler.tl
@@ -843,7 +843,6 @@
              (eavb (cdar nenv.(extend-var ex-args-var)))
              (tfrag me.(compile oreg nenv try-expr))
              (dfrag me.(compile oreg nenv desc-expr))
-             (coreg (if (equal tfrag.oreg '(t 0)) oreg tfrag.oreg))
              (lhand (gensym "l"))
              (lhend (gensym "l"))
              (treg me.(alloc-treg))
@@ -853,35 +852,35 @@
                        (mac-param-bind form (sym params . body) cl
                          (let* ((cl-src ^(apply (lambda ,params ,*body)
                                                 ,ex-sym-var ,ex-args-var))
-                                (cfrag me.(compile coreg nenv (expand cl-src)))
+                                (cfrag me.(compile oreg nenv (expand cl-src)))
                                 (lskip (gensym "l")))
-                           (new (frag coreg
+                           (new (frag oreg
                                       ^((gcall ,treg
                                                ,me.(get-sidx 'exception-subtype-p)
                                                ,esvb.loc
                                                ,me.(get-dreg sym))
                                         (if ,treg ,lskip)
                                         ,*cfrag.code
-                                        ,*me.(maybe-mov coreg cfrag.oreg)
+                                        ,*me.(maybe-mov oreg cfrag.oreg)
                                         ,*(unless (eql i nclauses)
                                             ^((jmp ,lhend)))
                                         ,lskip)
                                       cfrag.fvars
                                       cfrag.ffuns)))))))
         me.(free-treg treg)
-        (new (frag coreg
+        (new (frag oreg
                    ^((frame ,nenv.lev ,nenv.v-cntr)
                      ,*dfrag.code
                      (catch ,esvb.loc ,eavb.loc
                             ,me.(get-dreg symbols) ,dfrag.oreg ,lhand)
                      ,*tfrag.code
-                     ,*me.(maybe-mov coreg tfrag.oreg)
+                     ,*me.(maybe-mov oreg tfrag.oreg)
                      (jmp ,lhend)
                      ,lhand
                      ,*(mappend .code cfrags)
                      ,lhend
-                     (end ,coreg)
-                     (end ,coreg))
+                     (end ,oreg)
+                     (end ,oreg))
                    (uni tfrag.fvars [reduce-left uni cfrags nil .fvars])
                    (uni tfrag.ffuns [reduce-left uni cfrags nil .ffuns])))))))