diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 68 |
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 ...) |