Add dead code elimination pass.

2 files changed, 159 insertions, 16 deletions

diff --git a/chickadee/graphics/path.scm b/chickadee/graphics/path.scm
index 679995e..fac8c2c 100644
--- a/chickadee/graphics/path.scm
+++ b/chickadee/graphics/path.scm
@@ -1245,10 +1245,10 @@
   (out vec4 frag-color)
   (uniform vec4 color)
   (uniform float feather)
-  (uniform int stroke-closed)
+  ;(uniform int stroke-closed)
   (uniform float stroke-width)
   (uniform int stroke-cap)
-  (uniform float stroke-miter-limit)
+  ;(uniform float stroke-miter-limit)
   (if (<= (-> color w) 0.0)
       (discard)
       (let* ((infinity (/ 1.0 0.0))
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 0434db3..bea3e95 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -18,10 +18,10 @@
 ;;; Commentary:
 ;;
 ;; The Seagull shading language is a purely functional, statically
-;; typed, Scheme-like language that can be compiled to GLSL code.  The
-;; reality of how GPUs work imposes some significant language
-;; restrictions, but they are restrictions anyone who writes shader
-;; code is already used to.
+;; typed, Scheme-like language that compiles to GLSL.  The reality of
+;; how GPUs work imposes some significant language restrictions, but
+;; they are restrictions anyone who writes shader code is already used
+;; to.
 ;;
 ;; Features:
 ;; - Purely functional
@@ -40,10 +40,10 @@
 ;; TODO:
 ;; - Loops
 ;; - User defined structs
-;; - Dead code elimination (error when a uniform is eliminated)
-;; - Multiple GLSL versions
 ;; - Better error messages (especially around type predicate failure)
 ;; - Refactor to add define-primitive syntax
+;; - Helper function modules
+;; - Shader composition
 ;;
 ;;; Code:
 (define-module (chickadee graphics seagull)
@@ -55,12 +55,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
-  #:export (compile-seagull-module
-            compile-shader
-            link-seagull-modules
-            define-vertex-shader
-            define-fragment-shader
-            seagull-module?
+  #:export (seagull-module?
             seagull-module-vertex?
             seagull-module-fragment?
             seagull-module-stage
@@ -69,7 +64,12 @@
             seagull-module-uniforms
             seagull-module-source
             seagull-module-compiled
-            seagull-module-global-map))
+            seagull-module-global-map
+            compile-seagull-module
+            compile-shader
+            link-seagull-modules
+            define-vertex-shader
+            define-fragment-shader))
 
 ;; The Seagull compiler is designed as a series of source-to-source
 ;; program transformations (as described in "Compilation by Program
@@ -676,6 +676,148 @@
 
 
 ;;;
+;;; Dead code elimination
+;;;
+
+;; Find and remove unused variable bindings.  Report errors for unused
+;; globals, as they will cause problems later when the graphics
+;; driver's GLSL compiler eliminates them.  This also takes care of
+;; what would be an issue later on: If an 'outputs' form is bound to
+;; an unused variable, the GLSL emitter would emit global variable
+;; mutations even though they shouldn't happen!  This is a quirk of
+;; 'outputs' being the only form that produces side-effects but dead
+;; code elimination takes care of the problem.
+
+(define &seagull-unused-global-error
+  (make-exception-type '&seagull-unused-global-error &error '(variable)))
+
+(define make-seagull-unusued-global-error
+  (record-constructor &seagull-unused-global-error))
+
+(define seagull-unused-global-variable
+  (exception-accessor &seagull-unused-global-error
+                      (record-accessor &seagull-unused-global-error 'variable)))
+
+(define (unused-variable? var exp)
+  (define (unused-in-list? exps)
+    (every (lambda (exp) (unused-variable? var exp)) exps))
+  (match exp
+    ((? immediate?) #t)
+    ((? symbol?)
+     (not (eq? exp var)))
+    (('if predicate consequent alternate)
+     (and (unused-variable? var predicate)
+          (unused-variable? var consequent)
+          (unused-variable? var alternate)))
+    (('lambda (params ...) body)
+     (unused-variable? var body))
+    (('values exps ...)
+     (unused-in-list? exps))
+    (('let ((names exps) ...) body)
+     (and (unused-in-list? exps)
+          (unused-variable? var body)))
+    (('primcall operator args ...)
+     (unused-in-list? args))
+    (('call operator args ...)
+     (and (unused-variable? var operator)
+          (unused-in-list? args)))
+    (('struct-ref exp field)
+     (unused-variable? var exp))
+    (('array-ref array-exp index-exp)
+     (and (unused-variable? var array-exp)
+          (unused-variable? var index-exp)))
+    (('outputs (names exps) ...)
+     (and (unused-in-list? names) (unused-in-list? exps)))
+    (('top-level _ body)
+     (unused-variable? var body))))
+
+(define (prune:list exps)
+  (map prune exps))
+
+(define (prune:if predicate consequent alternate)
+  `(if ,(prune predicate)
+       ,(prune consequent)
+       ,(prune alternate)))
+
+(define (prune:lambda params body)
+  `(lambda ,params ,(prune body)))
+
+(define (prune:values exps)
+  (prune:list exps))
+
+(define (prune:let names exps body)
+  (define bindings
+    (filter-map (lambda (name exp)
+                  (if (unused-variable? name body)
+                      #f
+                      (list name exp)))
+                names exps))
+  ;; Remove 'let' if all bindings are dead.
+  (if (null? bindings)
+      (prune body)
+      `(let ,bindings ,(prune body))))
+
+(define (prune:primcall operator args)
+  `(primcall ,operator ,@(prune:list args)))
+
+(define (prune:call operator args)
+  `(call ,(prune operator) ,@(prune:list args)))
+
+(define (prune:struct-ref exp field)
+  `(struct-ref ,(prune exp) ,field))
+
+(define (prune:array-ref array-exp index-exp)
+  `(array-ref ,(prune array-exp)
+              ,(prune index-exp)))
+
+(define (prune:outputs names exps)
+  `(outputs ,@(map (lambda (name exp)
+                     (list name
+                           (prune exp)))
+                   names exps)))
+
+(define (prune:top-level qualifiers type-descriptors names body)
+  (for-each (lambda (qualifier type-desc name)
+              (when (unused-variable? name body)
+                (raise-exception
+                 (make-exception
+                  (make-seagull-unusued-global-error name)
+                  (make-exception-with-origin prune:top-level)
+                  (make-exception-with-message
+                   (format #f "seagull: global variable '~a ~a ~a' is unused"
+                           qualifier type-desc name))
+                  (make-exception-with-irritants (list name))))))
+            qualifiers type-descriptors names)
+  `(top-level ,(map list qualifiers type-descriptors names)
+              ,(prune body)))
+
+(define (prune exp)
+  (match exp
+    ((or (? immediate?) (? symbol?))
+     exp)
+    (('if predicate consequent alternate)
+     (prune:if predicate consequent alternate))
+    (('lambda (params ...) body)
+     (prune:lambda params body))
+    (('values exps ...)
+     (prune:values exps))
+    (('let ((names exps) ...) body)
+     (prune:let names exps body))
+    (('primcall operator args ...)
+     (prune:primcall operator args))
+    (('call operator args ...)
+     (prune:call operator args))
+    (('struct-ref exp field)
+     (prune:struct-ref exp field))
+    (('array-ref array-exp index-exp)
+     (prune:array-ref array-exp index-exp))
+    (('outputs (names exps) ...)
+     (prune:outputs names exps))
+    (('top-level ((qualifiers type-descs names) ...) body)
+     (prune:top-level qualifiers type-descs names body))))
+
+
+;;;
 ;;; Function hoisting
 ;;;
 
@@ -2734,7 +2876,8 @@
       (define-values (expanded global-map)
         (expand source* stage (top-level-env)))
       (let* ((simplified (simplify-exp expanded (empty-env)))
-             (hoisted (hoist-functions* simplified))
+             (pruned (prune simplified))
+             (hoisted (hoist-functions* pruned))
              (inferred (infer-types hoisted stage))
              (resolved (resolve-overloads inferred stage)))
         (values resolved global-map (unique-identifier-counter))))))