From 3cd4639e3056eb3ed1d6bb34fa73d23bd4c66441 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sat, 21 Jan 2023 10:32:27 -0500
Subject: Constant propagation and partial evaluation.

---
 chickadee/graphics/seagull.scm | 99 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 99 insertions(+)

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index f7dd555..ebb79a0 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -109,6 +109,9 @@
         (make-exception-with-message "seagull: unbound variable")
         (make-exception-with-irritants (list name env))))))
 
+(define (lookup* name env)
+  (assq-ref env name))
+
 (define (lookup-all names env)
   (map (lambda (name) (lookup name env)) names))
 
@@ -312,6 +315,102 @@
        (make-exception-with-message "seagull: invalid syntax")
        (make-exception-with-irritants (list exp)))))))
 
+
+;;;
+;;; Constant propagation and partial evaluation
+;;;
+
+;; Replace references to constants (variables that store an immediate
+;; value: integer, float, boolean) with the constants themselves.
+;; Then look for opportunities to evaluate primitive expressions that
+;; have constant arguments.  This will make the type inferencer's job
+;; a bit easier.
+
+(define (propagate:if predicate consequent alternate env)
+  `(if ,(propagate-constants predicate env)
+       ,(propagate-constants consequent env)
+       ,(propagate-constants alternate env)))
+
+(define (propagate:lambda params body env)
+  `(lambda ,params ,(propagate-constants body env)))
+
+(define (propagate:let names exps body env)
+  (define exps*
+    (map (lambda (exp)
+           (propagate-constants exp env))
+         exps))
+  ;; Extend environment with known constants.
+  (define env*
+    (fold (lambda (name exp env*)
+            (if (immediate? exp)
+                (extend-env name exp env*)
+                env*))
+          env names exps*))
+  ;; Drop all bindings for constant expressions.
+  (define bindings
+    (filter-map (lambda (name exp)
+                  (if (immediate? exp)
+                      #f
+                      (list name exp)))
+                names exps*))
+  ;; If there are no bindings left, remove the 'let' entirely.
+  (if (null? bindings)
+      (propagate-constants body env*)
+      `(let ,bindings
+         ,(propagate-constants body env*))))
+
+(define (propagate:primcall operator args env)
+  `(primcall ,operator
+             ,@(map (lambda (arg)
+                      (propagate-constants arg env))
+                    args)))
+
+(define (propagate:call operator args env)
+  `(call ,(propagate-constants operator env)
+         ,@(map (lambda (arg)
+                  (propagate-constants arg env))
+                args)))
+
+;; The division of two integers can result in a rational, non-integer,
+;; such as 1/2.  This isn't how integer division works in GLSL, so we
+;; need to round the result to an integer.
+(define (glsl-divide x y)
+  (let ((result (/ x y)))
+    (if (or (float? result) (integer? result))
+        result
+        (round result))))
+
+(define (propagate:arithmetic op x y env)
+  (define x* (propagate-constants x env))
+  (define y* (propagate-constants y env))
+  (if (or (and (exact-integer? x*) (exact-integer? y*))
+          (and (float? x*) (float? y*)))
+      (let ((op* (case op
+                   ((+) +)
+                   ((-) -)
+                   ((*) *)
+                   ((/) glsl-divide))))
+        (op* x* y*))
+      `(primcall ,op ,x* ,y*)))
+
+(define (propagate-constants exp env)
+  (match exp
+    ((? immediate?) exp)
+    (('var name _)
+     (or (lookup* name env) exp))
+    (('if predicate consequent alternate)
+     (propagate:if predicate consequent alternate env))
+    (('lambda (params ...) body)
+     (propagate:lambda params body env))
+    (('let ((names exps) ...) body)
+     (propagate:let names exps body env))
+    (('primcall (and (or '+ '- '* '/) op) x y)
+     (propagate:arithmetic op x y env))
+    (('primcall operator args)
+     (propagate:primcall operator args env))
+    (('call operator args ...)
+     (propagate:call operator args env))))
+
 
 ;;;
 ;;; Function hoisting
-- 
cgit v1.2.3