compiler: start of constant-folding implementation.

Introducing folding of certain expressions that can be
evaluated at compile time, with some special handling for
common arithmetic functions, in which we can collapse
consecutive arguments that are constant integer expressions.

* share/txr/stdlib/compiler.tl (%const-foldable-funs%): New
global variable.
(compiler compile): Send multiplication and division through
new methods that that treat integer arguments.
(compiler comp-arith-form, compiler comp-neg-arith-form): New
methods.
(comp-fun-form): Apply constant folding to a proper function
call whose operator is listed in %const-foldable-funs%.
(reduce-constant): New function.

1 files changed, 46 insertions, 0 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 4b71b572..774a1616 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -258,6 +258,8 @@
 
 (defvarl %bin-op% (relate %nary-ops% %bin-ops% nil))
 
+(defvarl %const-foldable-funs% '(+ - * / b- b+ b* b/ car cdr cadr caddr first second))
+
 (defvarl assumed-fun)
 
 (defvar *dedup*)
@@ -432,6 +434,8 @@
                            sys:qquote sys:unquote sys:splice)
                (compile-error form "unexpanded quasiquote encountered"))
               ;; function call
+              ((+ *) me.(comp-arith-form oreg env form))
+              ((- /) me.(comp-arith-neg-form oreg env form))
               (t me.(comp-fun-form oreg env form))))
            ((and (consp sym)
                  (eq (car sym) 'lambda)) me.(compile oreg env ^(call ,*form)))
@@ -1154,6 +1158,32 @@
   (let ((qexp (expand-quasi form)))
     me.(compile oreg env (expand qexp))))
 
+(defmeth compiler comp-arith-form (me oreg env form)
+  (let ((rform (reduce-constant form)))
+    (tree-case rform
+      ((op . args)
+       (let* ((pargs [partition-by constantp args])
+              (fargs (append-each ((pa pargs))
+                       (if (and (constantp (car pa))
+                                (all pa [chain eval integerp]))
+                         (list (eval ^(,op ,*pa)))
+                         pa))))
+         me.(comp-fun-form oreg env ^(,op ,*fargs))))
+      (else me.(compile oreg env rform)))))
+
+(defmeth compiler comp-arith-neg-form (me oreg env form)
+  (if (> (len form) 3)
+    (tree-bind (nop . args) form
+      (let ((op (caseq nop (- '+) (/ '*)))
+            (a1 (car args)))
+        (if (and (eq nop '-)
+                 (constantp a1))
+          me.(comp-arith-form oreg env
+                              ^(,op (- ,a1) ,*(cdr args)))
+          me.(comp-fun-form oreg env
+                            ^(,nop ,(car args) (,op ,*(cdr args)))))))
+    me.(comp-fun-form oreg env form)))
+
 (defmeth compiler comp-fun-form (me oreg env form)
   (match-case form
     ((equal @a @b)
@@ -1176,6 +1206,11 @@
     ((@(or identity + * min max) @a)
      (return-from comp-fun-form me.(compile oreg env a))))
 
+  (tree-case form
+    ((sym . args)
+     (if (member sym %const-foldable-funs%)
+       (set form (reduce-constant form)))))
+
   (when (or (atom form) (special-operator-p (car form)))
     (return-from comp-fun-form me.(compile oreg env form)))
 
@@ -1505,6 +1540,17 @@
        ^(,op ,a ,*args))
       (@else else))))
 
+(defun reduce-constant (form)
+  (if (consp form)
+    (tree-bind (op . args) form
+      (if (member op %const-foldable-funs%)
+        (let ((cargs [mapcar reduce-constant args]))
+          (if [all cargs constantp]
+            ^(quote ,(eval ^(,op ,*cargs)))
+            ^(,op ,*cargs)))
+        form))
+    form))
+
 (defun expand-quasi-mods (obj mods : form)
   (let (plist num sep rng-ix scalar-ix-p flex gens)
     (flet ((get-sym (exp)