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