diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 48 |
1 files changed, 29 insertions, 19 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index abd4429..70ff46b 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -1191,15 +1191,15 @@ ;; a bit easier. (define (simplify:list exps env) - (map (lambda (exp) (simplify-exp exp env)) exps)) + (map (lambda (exp) (simplify exp env)) exps)) (define (simplify:if predicate consequent alternate env) - `(if ,(simplify-exp predicate env) - ,(simplify-exp consequent env) - ,(simplify-exp alternate env))) + `(if ,(simplify predicate env) + ,(simplify consequent env) + ,(simplify alternate env))) (define (simplify:lambda params body env) - `(lambda ,params ,(simplify-exp body env))) + `(lambda ,params ,(simplify body env))) (define (simplify:values exps env) `(values ,@(simplify:list exps env))) @@ -1222,9 +1222,9 @@ names exps*)) ;; If there are no bindings left, remove the 'let' entirely. (if (null? bindings) - (simplify-exp body env*) + (simplify body env*) `(let ,bindings - ,(simplify-exp body env*)))) + ,(simplify body env*)))) (define (simplify:let-values names exps body env) (define exps* (simplify:list exps env)) @@ -1264,9 +1264,9 @@ names exps*)) ;; If there are no bindings left, remove the 'let' entirely. (if (null? bindings) - (simplify-exp body env*) + (simplify body env*) `(let-values ,bindings - ,(simplify-exp body env*)))) + ,(simplify body env*)))) (define (simplify:primcall op args env) (let* ((primitive (lookup-seagull-primitive op)) @@ -1277,30 +1277,30 @@ `(primcall ,op ,@args*)))) (define (simplify:call operator args env) - `(call ,(simplify-exp operator env) + `(call ,(simplify operator env) ,@(simplify:list args env))) (define (simplify:struct-ref exp field env) - `(struct-ref ,(simplify-exp exp env) ,field)) + `(struct-ref ,(simplify exp env) ,field)) (define (simplify:array-ref array-exp index-exp env) - `(array-ref ,(simplify-exp array-exp env) - ,(simplify-exp index-exp env))) + `(array-ref ,(simplify array-exp env) + ,(simplify index-exp env))) (define (simplify:top-level inputs body env) `(top-level ,inputs - ,(simplify-exp body env))) + ,(simplify body env))) (define (simplify:outputs names exps env) `(outputs ,@(map (lambda (name exp) - (list name (simplify-exp exp env))) + (list name (simplify exp env))) names exps))) -(define (simplify-exp exp env) +(define (simplify exp env) (match exp ((? constant?) exp) ((? symbol?) - (or (lookup* exp env) exp)) + (lookup* exp env exp)) (('if predicate consequent alternate) (simplify:if predicate consequent alternate env)) (('lambda (params ...) body) @@ -1324,6 +1324,9 @@ (('top-level inputs body) (simplify:top-level inputs body env)))) +(define (simplify* exp) + (simplify exp (empty-env))) + ;;; ;;; Dead code elimination @@ -3209,7 +3212,7 @@ ,body))) (define-values (expanded global-map) (expand* source* stage)) - (let* ((simplified (simplify-exp expanded (empty-env))) + (let* ((simplified (simplify expanded (empty-env))) (pruned (prune simplified)) (hoisted (hoist-functions* pruned)) (inferred (infer-types hoisted stage)) @@ -3483,7 +3486,14 @@ vec4 texture(samplerCube tex, vec3 coord) { (define-meta-command ((seagull-expand chickadee) repl stage exp) "seagull-expand STAGE EXP Run the expander on EXP for shader STAGE." - (pretty-print (expand exp stage (empty-env)))) + (parameterize ((unique-identifier-counter 0)) + (pretty-print (expand* exp stage)))) + +(define-meta-command ((seagull-simplify chickadee) repl stage exp) + "seagull-simplify STAGE EXP +Run the partial evaluator on EXP for shader STAGE." + (parameterize ((unique-identifier-counter 0)) + (pretty-print (simplify* (expand* exp stage))))) (define-meta-command ((seagull-inspect chickadee) repl module) "seagull-inspect MODULE |