summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/seagull.scm68
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 ...)