From b4045996e6ba899a982561d38467f3f118624a12 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Tue, 27 Mar 2018 06:36:36 -0700
Subject: compiler: recognize call and apply forms.

* share/txr/stdlib/compiler.tl (compiler): New slots, gcallop
and callop.
(compiler comp-fun-form): Restructured to handle apply and
call forms, turning them into better code, exploiting the
call, gcall, apply and gapply instructions.
(compiler comp-call): Take opcode argument so apply calls can
be handled.
---
 share/txr/stdlib/compiler.tl | 34 +++++++++++++++++++++++-----------
 1 file changed, 23 insertions(+), 11 deletions(-)

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 00fcaf65..7418ac93 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -115,7 +115,9 @@
   (data (hash :eql-based))
   (fidx (hash :eql-based))
   (ftab (hash :eql-based))
-  last-form)
+  last-form
+  (:static gcallop (relate '(apply usr:apply call) '(gapply gapply gcall)))
+  (:static callop (relate '(apply usr:apply call) '(apply apply call))))
 
 (defmeth compiler get-dreg (me atom)
   (iflet ((dreg [me.dreg atom]))
@@ -764,18 +766,28 @@
     me.(compile oreg env (expand qexp))))
 
 (defmeth compiler comp-fun-form (me oreg env sym args)
-  (condlet
-    (((fbind env.(lookup-fun sym)))
-     me.(comp-call-impl oreg env 'call fbind.loc args))
-    (((fidx me.(get-fidx sym)))
-     (caseq sym
-       (call me.(comp-call oreg env args))
-       (t me.(comp-call-impl oreg env 'gcall fidx args))))))
-
-(defmeth compiler comp-call (me oreg env args)
+  (caseql sym
+    ((call apply usr:apply)
+     (let ((gopcode [me.gcallop sym])
+           (opcode [me.callop sym]))
+       (tree-case (car args)
+         ((op arg) (if (and (eq op 'fun) (bindable arg))
+                     (let ((fbind env.(lookup-fun arg)))
+                       me.(comp-call-impl oreg env (if fbind opcode gopcode)
+                                          (if fbind fbind.loc me.(get-fidx arg))
+                                          (cdr args)))
+                     :))
+         (arg me.(comp-call oreg env
+                            (if (eq sym 'usr:apply) 'apply sym) args)))))
+    (t (let ((fbind env.(lookup-fun sym)))
+         me.(comp-call-impl oreg env (if fbind 'call 'gcall)
+                            (if fbind fbind.loc me.(get-fidx sym))
+                            args)))))
+
+(defmeth compiler comp-call (me oreg env opcode args)
   (tree-bind (fform . fargs) args
     (let* ((ffrag me.(compile oreg env fform))
-           (cfrag me.(comp-call-impl oreg env 'call ffrag.oreg fargs)))
+           (cfrag me.(comp-call-impl oreg env opcode ffrag.oreg fargs)))
       (new (frag cfrag.oreg
                  (append ffrag.code
                          cfrag.code)
-- 
cgit v1.2.3