compiler: bug: symbol not in ffuns in call forms.

This bug causes forms like (call (fun 'foo) ...) not to
register foo as a free reference in the function space,
leading to inappropriate lambda lifting optimizations.  The
compiler thinks that a lambda is safe to move because that
lambda doesn't reference any surrounding lexical functions,
which is incorrect.

A failing test case for this is

  (compile-file "tests/012/man-or-boy.tl")

at *opt-level* 3 or higher. A bogus error occurs similar
to "function #:g0144 is not defined", due to that function
being referenced from a lifted lambda, and not being in
its scope.

* share/txr/stdlib/compiler.tl (compiler (comp-fun-form,
comp-apply-call)): Pass the function symbol as an extra
argument to comp-fun-form so that it's added to ffuns.
(compiler comp-call-impl): Take new optional argument: a
symbol to be added to the ffuns slot of the returned fragment,
indicating that a function symbol is referenced.

1 files changed, 9 insertions, 6 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 75070f3b..a96ba684 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -1344,7 +1344,7 @@
         (macrolet ((comp-fun ()
                       'me.(comp-call-impl oreg env (if fbind 'call 'gcall)
                                           (if fbind fbind.loc me.(get-sidx sym))
-                                          args)))
+                                          args sym)))
           (if (and (>= olev 3)
                    (not fbind)
                    (not *load-time*)
@@ -1392,7 +1392,7 @@
                             (let ((fbind env.(lookup-fun arg t)))
                               me.(comp-call-impl oreg env (if fbind opcode gopcode)
                                                  (if fbind fbind.loc me.(get-sidx arg))
-                                                 (cdr args))))
+                                                 (cdr args) arg)))
                            ((and (consp arg) (eq (car arg) 'lambda))
                             me.(comp-fun-form oreg env ^(,sym ,arg ,*(cdr args))))
                            (t :)))
@@ -1414,7 +1414,7 @@
                  (uni ffrag.fvars cfrag.fvars)
                  (uni ffrag.ffuns cfrag.ffuns))))))
 
-(defmeth compiler comp-call-impl (me oreg env opcode freg args)
+(defmeth compiler comp-call-impl (me oreg env opcode freg args : extra-ffun)
   (let* ((aoregs nil)
          (afrags (collect-each ((arg args))
                    (let* ((aoreg me.(alloc-treg))
@@ -1422,13 +1422,16 @@
                      (if (nequal afrag.oreg aoreg)
                        me.(free-treg aoreg)
                        (push aoreg aoregs))
-                     afrag))))
+                     afrag)))
+         (fvars [reduce-left uni afrags nil .fvars])
+         (ffuns [reduce-left uni afrags nil .ffuns]))
     me.(free-tregs aoregs)
+    (when extra-ffun
+      (pushnew extra-ffun ffuns))
     (new (frag oreg
                ^(,*(mappend .code afrags)
                  (,opcode ,oreg ,freg ,*(mapcar .oreg afrags)))
-               [reduce-left uni afrags nil .fvars]
-               [reduce-left uni afrags nil .ffuns]))))
+               fvars ffuns))))
 
 (defmeth compiler comp-inline-lambda (me oreg env opcode lambda args)
   (let ((reg-args args) apply-list-arg)