From bae56aea71113c94afecd085d54209feb6a85937 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Wed, 3 Mar 2021 07:46:53 -0800
Subject: compiler: lift functional expressions to load-time.

The idea behind this optimization is that certain expressions
that only calculate functions can be hoisted to load time.

These expressions meet these criteria:

1. Are not already in a top-level or load-time context.

2. Are function calls to a standard library
   functional operator like chain andf, orf, juxt, ...

3. Do not access any variables.

3. Do not access any functions other than public (usr package)
   global functions in the standard library.

An example of such an expression might be:

   [chain cdr [iff symbolp list]]

If such an expression is embedded in a function, we don't want
the function to re-calculate it every time, which requires
time and generates garbage. We can transform it to the
equivalent of:

   (load-time [chain cdr [iff symbolp list]])

to have it calculated once.

* share/txr/stdlib/compiler.tl (%functional-funs%,
%functional%): New global variables.
(compiler comp-fun-form): After compiling the function call,
check for the conditions for lifting. If so, compile the form
again as a load-time literal. The logic is similar to how
lambdas are lifted to load-time, though the conditions are
different.
---
 share/txr/stdlib/compiler.tl | 17 +++++++++++++++++
 1 file changed, 17 insertions(+)

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index d6ca1f45..5182fda0 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -294,6 +294,12 @@
 
 (defvarl %const-foldable% (hash-list %const-foldable-funs% :eq-based))
 
+(defvarl %functional-funs%
+  '(chain chand juxt andf orf notf iff iffi dup flipargs if or and
+    progn prog1 prog2 retf apf ipf callf mapf tf nilf))
+
+(defvarl %functional% (hash-list %functional-funs% :eq-based))
+
 (defvarl assumed-fun)
 
 (defvar *dedup*)
@@ -1252,6 +1258,17 @@
            (cfrag me.(comp-call-impl oreg env (if fbind 'call 'gcall)
                                      (if fbind fbind.loc me.(get-sidx sym))
                                      args)))
+      (when (and (not fbind)
+                 (not *load-time*)
+                 [%functional% sym])
+        (let ((ok-lift-var-pov (null cfrag.fvars))
+              (ok-lift-fun-pov (all cfrag.ffuns
+                                    (lambda (sym)
+                                      (and (not env.(lookup-fun sym))
+                                           (eq (symbol-package sym)
+                                               user-package))))))
+          (when (and ok-lift-var-pov ok-lift-fun-pov)
+            (set cfrag me.(compile oreg env ^(sys:load-time-lit nil ,form))))))
       (pushnew sym cfrag.ffuns)
       cfrag)))
 
-- 
cgit v1.2.3