Expand primitives that can be evaluated at compile time.

1 files changed, 36 insertions, 32 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 11b38eb..a1367b7 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -637,24 +637,6 @@
       `(let ,bindings
          ,(simplify-exp body env*))))
 
-(define (simplify:primcall operator args env)
-  `(primcall ,operator
-             ,@(map (lambda (arg)
-                      (simplify-exp arg env))
-                    args)))
-
-(define (simplify:call operator args env)
-  `(call ,(simplify-exp operator env)
-         ,@(map (lambda (arg)
-                  (simplify-exp arg env))
-                args)))
-
-(define (simplify:struct-ref exp field env)
-  `(struct-ref ,(simplify-exp exp env) ,field))
-
-(define (simplify:array-ref array-exp index-exp env)
-  `(array-ref ,(simplify-exp array-exp env)
-              ,(simplify-exp index-exp env)))
 (define (simplify:let-values names exps body env)
   (define exps* (simplify:list exps env))
   ;; Extend environment with known constants.
@@ -706,18 +688,42 @@
         result
         (round result))))
 
-(define (simplify:arithmetic op x y env)
-  (define x* (simplify-exp x env))
-  (define y* (simplify-exp 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 %simplify-primitives
+  `((+ . ,+)
+    (- . ,-)
+    (* . ,*)
+    (/ . ,glsl-divide)
+    (= . ,=)
+    (< . ,<)
+    (<= . ,<=)
+    (> . ,>)
+    (>= . ,>=)
+    (mod . ,mod)
+    (sqrt . ,sqrt)
+    (pow . ,expt)
+    (min . ,min)
+    (max . ,max)
+    (sin . ,sin)
+    (cos . ,cos)
+    (tan . ,tan)))
+
+(define (simplify:primcall op args env)
+  (let ((proc (assq-ref %simplify-primitives op))
+        (args* (simplify:list args env)))
+    (if (and (procedure? proc) (every immediate? args*))
+        (apply proc args*)
+        `(primcall ,op ,@args*))))
+
+(define (simplify:call operator args env)
+  `(call ,(simplify-exp operator env)
+         ,@(simplify:list args env)))
+
+(define (simplify:struct-ref exp field env)
+  `(struct-ref ,(simplify-exp exp env) ,field))
+
+(define (simplify:array-ref array-exp index-exp env)
+  `(array-ref ,(simplify-exp array-exp env)
+              ,(simplify-exp index-exp env)))
 
 (define (simplify:top-level inputs body env)
   `(top-level ,inputs
@@ -741,8 +747,6 @@
      (simplify:values exps env))
     (('let ((names exps) ...) body)
      (simplify:let names exps body env))
-    (('primcall (and (or '+ '- '* '/) op) x y)
-     (simplify:arithmetic op x y env))
     (('let-values ((names exps) ...) body)
      (simplify:let-values names exps body env))
     (('primcall operator args ...)