From 094da386216658e6529f9045ea74b2f280e4b5f9 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Fri, 23 Mar 2018 06:38:42 -0700
Subject: compiler: streamline tree-case

The setting of an error variable upon destructuring mismatch
is not useful; it just takes extra instructions to check for a
colon return out of the body or that variable being set.
Let's have expand-bind-mac-params generate code which
returns that symbol itself of assigning to it. The
caller can then specify : for the strict parameter. A
destructuring mismatch turns into a : return value, exactly
the same as the value which indicates "fall through to next
case".

* share/txr/stdlib/compiler.tl (compiler comp-tree-case):
Don't generate the err-var; remove all references to it.
Pass : to expand-bind-mac-params as the strict parameter,
rather than err-var.sym. Generate much simplified code
after the cfrag: just test for a colon and continue
through to the next case or else branch to the end.
In the last case, the fall through path precipiates to the
end, so we insert an instruction to clobber the : in the
return register with a nil.
(expand-bind-mac-params): Eliminate assignments to strict;
it doesn't function as a variable any longer. Return
that symbol in the return-from forms.
---
 share/txr/stdlib/compiler.tl | 29 +++++++++--------------------
 1 file changed, 9 insertions(+), 20 deletions(-)

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 7d8a7bf9..2446c23a 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -604,7 +604,6 @@
            (nenv (new env up env co me))
            (obj-immut-var (cdar nenv.(extend-var (gensym))))
            (obj-var (cdar nenv.(extend-var (gensym))))
-           (err-var (cdar nenv.(extend-var (gensym))))
            (err-blk (cdar nenv.(extend-var (gensym))))
            (lout (gensym "l"))
            (objfrag me.(compile oreg env obj))
@@ -616,8 +615,7 @@
                                                    ,obj-immut-var.sym)
                                               ,(expand-bind-mac-params
                                                  form params
-                                                 nil obj-var.sym
-                                                 err-var.sym
+                                                 nil obj-var.sym :
                                                  err-blk.sym
                                                  body))))
                               (lerrtest (gensym "l"))
@@ -626,16 +624,9 @@
                          (new (frag oreg
                                     ^(,*cfrag.code
                                        ,*(maybe-mov oreg cfrag.oreg)
-                                       (ifq ,oreg ,me.(get-dreg :) ,lerrtest)
-                                       ,*(cond
-                                           ((eql i ncases)
-                                            ^((mov ,oreg nil)
-                                              (jmp ,lout)))
-                                           (t
-                                            ^((jmp ,lnext))))
-                                       ,lerrtest
-                                       (if ,err-var.loc ,lout)
-                                       ,*(if (neql i ncases) ^(,lnext)))
+                                       (ifq ,oreg ,me.(get-dreg :) ,lout)
+                                       ,*(if (eql i ncases)
+                                           ^((mov ,oreg nil))))
                                     cfrag.fvars
                                     cfrag.ffuns))))))
            (allfrags (cons objfrag cfrags)))
@@ -809,10 +800,9 @@
                                         ,(berr nil))))))
                              ((null strict) nil)
                              ((symbolp strict)
-                              ^((when (or (< ,plen ,nreq)
-                                          (> ,plen ,nfix))
-                                  (set ,strict t)
-                                  (return-from ,err-block nil)))))
+                              ^((if (or (< ,plen ,nreq)
+                                        (> ,plen ,nfix))
+                                  (return-from ,err-block ',strict)))))
                          ,*(append-each ((k key-pars))
                              (tree-bind (key . var) k
                                (push var vars)
@@ -872,9 +862,8 @@
                                 ^((if ,obj-var ,(berr nil))))
                                ((null strict) nil)
                                ((symbolp strict)
-                                ^((when ,obj-var
-                                    (set ,strict t)
-                                    (return-from ,err-block nil)))))))
+                                ^((if ,obj-var
+                                    (return-from ,err-block ',strict)))))))
                        (put-gen curs))))))
         (let ((bind-code (expand-rec params obj-var)))
           ^(let (,*(nreverse vars) ,plen ,*gen-stk)
-- 
cgit v1.2.3