Constant folding

[Ludovic Courtès]

Hello!

We should implement constant folding in the tree-il->glil pass.  A naive
implementation looks like this:

diff --git a/module/language/tree-il/compile-glil.scm 
b/module/language/tree-il/compile-glil.scm
index 86b610f..57a46c8 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -22,6 +22,7 @@
   #:use-module (system base syntax)
   #:use-module (system base pmatch)
   #:use-module (system base message)
+  #:use-module (srfi srfi-1)
   #:use-module (ice-9 receive)
   #:use-module (language glil)
   #:use-module (system vm instruction)
@@ -394,20 +395,28 @@
                             (cons (primitive-ref-name proc) (length args)))
                   (hash-ref *primcall-ops* (primitive-ref-name proc))))
          => (lambda (op)
-              (for-each comp-push args)
-              (emit-code src (make-glil-call op (length args)))
-              (case (instruction-pushes op)
-                ((0)
-                 (case context
-                   ((tail push vals) (emit-code #f (make-glil-void))))
-                 (maybe-emit-return))
-                ((1)
-                 (case context
-                   ((drop) (emit-code #f (make-glil-call 'drop 1))))
-                 (maybe-emit-return))
-                (else
-                 (error "bad primitive op: too many pushes"
-                        op (instruction-pushes op))))))
+              (if (every const? args)
+                  (let* ((proc (module-ref the-scm-module
+                                           (primitive-ref-name proc)))
+                         (args (map const-exp args)))
+                    ;; constant folding
+                    (emit-code src
+                               (make-glil-const (apply proc args))))
+                  (begin
+                    (for-each comp-push args)
+                    (emit-code src (make-glil-call op (length args)))
+                    (case (instruction-pushes op)
+                      ((0)
+                       (case context
+                         ((tail push vals) (emit-code #f (make-glil-void))))
+                       (maybe-emit-return))
+                      ((1)
+                       (case context
+                         ((drop) (emit-code #f (make-glil-call 'drop 1))))
+                       (maybe-emit-return))
+                      (else
+                       (error "bad primitive op: too many pushes"
+                              op (instruction-pushes op))))))))
         
         ;; da capo al fine
         ((and (lexical-ref? proc)

With that we get:

--8<---------------cut here---------------start------------->8---
scheme@(guile-user)> ,c (+ 2 3)
Disassembly of #<objcode b214e0>:

   0    (make-int8 5)                   ;; 5

--8<---------------cut here---------------end--------------->8---

instead of:

--8<---------------cut here---------------start------------->8---
scheme@(guile-user)> ,c (+ 2 3)
Disassembly of #<objcode ceb3a0>:

   0    (make-int8 2)                   ;; 2
   2    (make-int8 3)                   ;; 3
   4    (add)                           
   5    (return)                        

--8<---------------cut here---------------end--------------->8---

but:

--8<---------------cut here---------------start------------->8---
scheme@(guile-user)> ,c (+ 2 (+ 2 3) 4)
Disassembly of #<objcode b68ba0>:

   0    (make-int8 2)                   ;; 2
   2    (make-int8 5)                   ;; 5
   4    (make-int8 4)                   ;; 4
   6    (add)                           
   7    (add)                           
   8    (return)                        

--8<---------------cut here---------------end--------------->8---

Thanks,
Ludo’.