Added compiler pass output schema for easier phase mix-and-matching l…

…ater.

src/compiler/pass.rkt

@@ -11,22 +11,26 @@
 
 (provide (struct-out pass) run-pass sequence debug
          schema non-empty-string? non-empty-list? non-empty-hash? a-symbol? a-number? a-string?
-         a-pair? a-list? list-of? a-set? a-function? ast-subset?
+         a-pair? a-list? list-of? a-set? a-function? ast-subset? not-nil?
          schema-validation-error?)
 
-(struct pass (schema transform) #:transparent)
+(struct pass (input-schema transform output-schema) #:transparent)
 
 (define (run-pass pass env)
-  (unless (env-contains? env 'no-validation)
-    ((pass-schema pass) env))
-  ((pass-transform pass) env))
+  (if (env-contains? env 'no-validation)
+      ((pass-transform pass) env)
+      (let* ((pre ((pass-input-schema pass) env))
+             (result ((pass-transform pass) env))
+             (post ((pass-output-schema pass) result)))
+        result)))
 
 (define (sequence . passes)
   (pass (schema "sequence")
         (lambda (env)
           (foldl run-pass
                  env
-                 passes))))
+                 passes))
+        (schema "sequence output")))
 
 (define (schema hint . properties)
   (lambda (env)
@@ -49,7 +53,12 @@
   (pass (schema "debug")
         (lambda (env)
           (pretty-print (ast->plain (env-get env 'ast)))
-          env)))
+          env)
+        (schema "debug output")))
+
+(define (not-nil? val)
+  (when (equal? val '())
+    (schema-validation-error "Not a non-nil value" val)))
 
 (define (non-empty-string? val)
   (unless (and (string? val)

src/compiler/passes/alpha-conversion.rkt

@@ -20,7 +20,9 @@
   (pass (schema "alpha-convert"
                 'ast (ast-subset? '(const symbol if do let letrec fix binding lambda app primop-app)))
         (lambda (env)
-          (env-update env 'ast (partial alpha-rename (make-subs '()))))))
+          (env-update env 'ast (partial alpha-rename (make-subs '()))))
+        (schema "alpha-convert output"
+                'ast (ast-subset? '(const symbol if do let letrec fix binding lambda app primop-app)))))
 
 (define (alpha-rename subs expr)
   (define (loop subs expr)

src/compiler/passes/bindings.rkt

@@ -19,7 +19,11 @@
                                     if do let letrec binding lambda app
                                     primop-app def <error>)))
         (lambda (env)
-          (env-update env 'ast (partial analyze-bindings #f)))))
+          (env-update env 'ast (partial analyze-bindings #f)))
+        (schema "annotate-bindings output"
+                'ast (ast-subset? '(const symbol
+                                    if do let letrec binding lambda app
+                                    primop-app def <error>)))))
 
 (define (analyze-bindings within-letrec? expr)
   (match-ast expr

src/compiler/passes/builtins.rkt

@@ -19,7 +19,9 @@
                 'intrinsics a-list?
                 'ast (ast-subset? '(const symbol if do let letrec binding lambda app primop-app)))
         (lambda (env)
-          (env-update env 'ast (partial inline-app-ops (env-get env 'intrinsics))))))
+          (env-update env 'ast (partial inline-app-ops (env-get env 'intrinsics))))
+        (schema "inline-builtins output"
+                'ast (ast-subset? '(const symbol if do let letrec binding lambda app primop-app)))))
 
 (define (inline-app-ops builtins expr)
   (substitute (lambda (subs expr kont)

src/compiler/passes/closures.rkt

@@ -19,10 +19,11 @@
 (define closure-convert
   (pass (schema "closure-convert"
                 'globals a-set?
-                'ast (ast-subset? '(const symbol
-                                    if do let fix binding lambda app primop-app)))
+                'ast (ast-subset? '(const symbol if do let fix binding lambda app primop-app)))
         (lambda (env)
-          (env-update env 'ast (flip convert-closures (env-get env 'globals))))))
+          (env-update env 'ast (flip convert-closures (env-get env 'globals))))
+        (schema "closure-convert output"
+                'ast (ast-subset? '(const symbol if do let fix binding lambda app primop-app)))))
 
 (define (convert-closures expr globals)
   (match-ast expr

src/compiler/passes/const-folding.rkt

@@ -16,7 +16,9 @@
   (pass (schema "fold-constants"
                 'ast (ast-subset? '(const symbol if do let letrec fix binding lambda app primop-app)))
         (lambda (env)
-          (env-update env 'ast constant-folding))))
+          (env-update env 'ast constant-folding))
+        (schema "fold-constants output"
+                'ast (ast-subset? '(const symbol if do let letrec fix binding lambda app primop-app)))))
 
 (define (constant-folding expr)
   (map-ast (lambda (expr)

src/compiler/passes/const-propagation.rkt

@@ -18,7 +18,9 @@
   (pass (schema "propagate-constants"
                 'ast (ast-subset? '(const symbol if do let letrec fix binding lambda app primop-app)))
         (lambda (env)
-          (env-update env 'ast (partial constant-propagation (make-subs '()))))))
+          (env-update env 'ast (partial constant-propagation (make-subs '()))))
+        (schema "propagate-constants output"
+                'ast (ast-subset? '(const symbol if do let letrec fix binding lambda app primop-app)))))
 
 (define (constant-propagation subs expr)
   (propagate const-binding?

src/compiler/passes/const.rkt

@@ -19,7 +19,11 @@
                                     if do let letrec binding lambda app
                                     primop-app def <error>)))
         (lambda (env)
-          (env-update env 'ast wrap-constants))))
+          (env-update env 'ast wrap-constants))
+        (schema "annotate-constants output"
+                'ast (ast-subset? '(const number symbol string list
+                                    if do let letrec binding lambda app
+                                    primop-app def <error>)))))
 
 (define (wrap-constants expr)
   (case (ast-node-type expr)

src/compiler/passes/copy-propagation.rkt

@@ -18,7 +18,9 @@
   (pass (schema "propagate-copies"
                 'ast (ast-subset? '(const symbol if do let letrec fix binding lambda app primop-app)))
         (lambda (env)
-          (env-update env 'ast (partial copy-propagation (make-subs '()))))))
+          (env-update env 'ast (partial copy-propagation (make-subs '()))))
+        (schema "propagate-copies output"
+                'ast (ast-subset? '(const symbol if do let letrec fix binding lambda app primop-app)))))
 
 (define (copy-propagation subs expr)
   (propagate symbol-binding?

src/compiler/passes/cpc.rkt

@@ -22,7 +22,9 @@
                 'ast (ast-subset? '(const symbol if do let fix binding lambda app primop-app)))
         (lambda (env)
           (env-update env 'ast (lambda (expr)
-                                 (cpc expr #f (make-identity-continuation)))))))
+                                 (cpc expr #f (make-identity-continuation)))))
+        (schema "continuation-passing-convert output"
+                'ast (ast-subset? '(const symbol if do let fix binding lambda app primop-app)))))
 
 (define (make-identity-continuation)
   id)

src/compiler/passes/cse.rkt

@@ -19,7 +19,9 @@
                 'ast (ast-subset? '(const symbol if do let letrec fix binding lambda app primop-app)))
         (lambda (env)
           (env-update env 'ast (lambda (expr)
-                                   (cse (subexpr-extractor (env-get env 'intrinsics)) '() expr))))))
+                                   (cse (subexpr-extractor (env-get env 'intrinsics)) '() expr))))
+        (schema "eliminate-common-subexpressions output"
+                'ast (ast-subset? '(const symbol if do let letrec fix binding lambda app primop-app)))))
 
 (define (cse extract-subexprs subexprs expr)
   (let loop ((subexprs subexprs)

src/compiler/passes/dce.rkt

@@ -19,7 +19,9 @@
   (pass (schema "eliminate-dead-code"
                 'ast (ast-subset? '(const symbol if do let letrec fix binding lambda app primop-app)))
         (lambda (env)
-          (env-update env 'ast (partial dce (set))))))
+          (env-update env 'ast (partial dce (set))))
+        (schema "eliminate-dead-code output"
+                'ast (ast-subset? '(const symbol if do let letrec fix binding lambda app primop-app)))))
 
 (define (dce eta-disallow expr)
   (match-ast expr

src/compiler/passes/errors.rkt

@@ -22,7 +22,8 @@
                    (source-order errors))
               (raise-compilation-error (location 0 0)
                                        (format "Compilation aborted due to ~s errors." (length errors))))
-            env))))
+            env))
+        (schema "report-errors output")))
 
 (define (report-error env error)
   (let* ((location (compilation-error-location error))

src/compiler/passes/freevars.rkt

@@ -18,7 +18,11 @@
                                     if do let letrec fix binding lambda app ;; NOTE fix, since this pass is used multiple times.
                                     primop-app def <error>)))
         (lambda (env)
-          (env-update env 'ast compute-free-vars))))
+          (env-update env 'ast compute-free-vars))
+        (schema "annotate-free-vars output"
+                'ast (ast-subset? '(const symbol
+                                    if do let letrec fix binding lambda app
+                                    primop-app def <error>)))))
 
 (define (compute-free-vars expr)
   (map-ast (lambda (expr)

src/compiler/passes/generator.rkt

@@ -19,4 +19,6 @@
                         (generate-js env))
                        (else
                         (generate-scheme env)))))
-            (env-set env 'generated gen)))))
+            (env-set env 'generated gen)))
+        (schema "generate-target-code output"
+                'generated not-nil?)))

src/compiler/passes/globalization.rkt

@@ -22,7 +22,11 @@
             (-> env
                 (env-remove 'ast)
                 (env-set 'data (car result)
-                         'init (cadr result)))))))
+                         'init (cadr result)))))
+        (schema "globalize output"
+                'data (list-of? (a-pair? a-symbol?
+                                         (ast-subset? '(const symbol if do let binding lambda primop-app))))
+                'init (ast-subset? '(const symbol if do let binding primop-app)))))
 
 (define (hoist-values expr)
   (let* ((hoisted '())

src/compiler/passes/instrument.rkt

@@ -11,4 +11,5 @@
   (pass (schema "instrument"
                 'instrument a-function?)
         (lambda (env)
-          (env-update env 'ast (env-get env 'instrument)))))
+          (env-update env 'ast (env-get env 'instrument)))
+        (schema "instrument output")))

src/compiler/passes/lambdas.rkt

@@ -21,7 +21,9 @@
   (pass (schema "inline-lambdas"
                 'ast (ast-subset? '(const symbol if do let letrec fix binding lambda app primop-app)))
         (lambda (env)
-          (env-update env 'ast (partial lambda-inlining '())))))
+          (env-update env 'ast (partial lambda-inlining '())))
+        (schema "inline-lambdas output"
+                'ast (ast-subset? '(const symbol if do let letrec fix binding lambda app primop-app)))))
 
 (define (lambda-inlining lambdas expr)
   (let ((loop (partial traverse-ast lambda-inlining lambdas)))

src/compiler/passes/letrec-bindings.rkt

@@ -56,10 +56,11 @@
 
 (define reorder-letrec-bindings
   (pass (schema "reorder-letrec-bindings"
-                'ast (ast-subset? '(const symbol
-                                    if do let letrec binding lambda app primop-app)))
+                'ast (ast-subset? '(const symbol if do let letrec binding lambda app primop-app)))
         (lambda (env)
-          (env-update env 'ast reorder-letrec))))
+          (env-update env 'ast reorder-letrec))
+        (schema "reorder-letrec-bindings output"
+                'ast (ast-subset? '(const symbol if do let letrec binding lambda app primop-app)))))
 
 (define (reorder-letrec expr)
   (map-ast (lambda (expr)

src/compiler/passes/letrec-fix.rkt

@@ -18,10 +18,11 @@
 
 (define fix-letrec
   (pass (schema "fix-letrec"
-                'ast (ast-subset? '(const symbol
-                                          if do let letrec binding lambda app primop-app)))
+                'ast (ast-subset? '(const symbol if do let letrec binding lambda app primop-app)))
         (lambda (env)
-          (env-update env 'ast fixing-letrec))))
+          (env-update env 'ast fixing-letrec))
+        (schema "fix-letrec output"
+                'ast (ast-subset? '(const symbol if do let fix binding lambda app primop-app)))))
 
 (define (fixing-letrec expr)
   (map-ast (lambda (expr)

src/compiler/passes/macro-expander.rkt

@@ -26,4 +26,10 @@
                                                   (env-get env 'ast))))))
             (env-set env
                      'ast (car result)
-                     'errors (cadr result))))))
+                     'errors (cadr result))))
+        (schema "macro-expand output"
+                'errors a-list?
+                'ast (ast-subset? '(quote quasiquote unquote unquote-splicing
+                                    number symbol string list
+                                    if do let letrec binding lambda app
+                                    primop-app def <error>)))))

src/compiler/passes/metadata.rkt

@@ -12,9 +12,7 @@
 
 (define extract-metadata
   (pass (schema "extract-metadata"
-                'ast (ast-subset? '(const symbol
-                                          if do let letrec binding lambda app
-                                          primop-app def <error>))
+                'ast (ast-subset? '(const symbol if do let letrec binding lambda app primop-app def <error>))
                 'intrinsics a-list?)
         (lambda (env)
           (let* ((ast (env-get env 'ast))
@@ -24,7 +22,10 @@
                  (updated (cdr result)))
             (env-set env
                      'ast updated
-                     'intrinsics primitives)))))
+                     'intrinsics primitives)))
+        (schema "extract-metadata output"
+                'ast (ast-subset? '(const symbol if do let letrec binding lambda app primop-app def <error>))
+                'intrinsics a-list?)))
 
 (define (extract-intrinsics-metadata ast)
   (define (replace-with-nil expr)

src/compiler/passes/optimize.rkt

@@ -22,7 +22,8 @@
                            ((naive) optimize-naive)
                            ((super) optimize-super)))
                passes
-               env)))))
+               env)))
+        (schema "optimize output")))
 
 (define +optimization-loops+ 23)
 

src/compiler/passes/parser.rkt

@@ -297,7 +297,12 @@
                                                  "Expected a Spartan module, found something else:")))))))
             (env-set env
                      'ast (car result)
-                     'errors (cadr result))))))
+                     'errors (cadr result))))
+        (schema "parse output"
+                'ast (ast-subset? '(quote quasiquote unquote unquote-splicing
+                                    number symbol string list
+                                    primop-app body <error>))
+                'errors a-list?)))
 
 (define no-inline
   ;; NOTE Prevents inlining of this rule making it hit the cache more often and perform better.

src/compiler/passes/qq.rkt

@@ -26,7 +26,13 @@
                                           (expand-quasiquote (env-get env 'ast))))))
             (env-set env
                      'ast (car result)
-                     'errors (cadr result))))))
+                     'errors (cadr result))))
+        (schema "quasiquote-expand output"
+                'errors a-list?
+                'ast (ast-subset? '(quote quasiquote unquote unquote-splicing ;; NOTE Quasiquote et al can appear with (quote ,@value)
+                                    number symbol string list
+                                    if do let letrec binding lambda app
+                                    primop-app def <error>)))))
 
 (define (expand-quasiquote expr)
   (case (ast-node-type expr)

src/compiler/passes/rename.rkt

@@ -24,7 +24,11 @@
                               (map (lambda (v)
                                      (cons (symbol->safe (car v))
                                            (mangle-names (cdr v))))
-                                   values))))))
+                                   values))))
+        (schema "symbol-rename output"
+                'data (list-of? (a-pair? a-symbol?
+                                         (ast-subset? '(const symbol if do let binding lambda primop-app))))
+                'init (ast-subset? '(const symbol if do let binding primop-app)))))
 
 (define (mangle-names expr)
   (match-ast expr

src/compiler/passes/validate.rkt

@@ -21,21 +21,26 @@
                 'errors a-list?
                 'globals a-set?
                 'ast (ast-subset? '(const symbol
-                                    if do let letrec binding lambda app
-                                    primop-app def <error>)))
-   (lambda (env)
-     (let ((result (collect-errors (env-get env 'errors)
-                                   (lambda ()
-                                     (let ((expr (env-get env 'ast))
-                                           (globals (env-get env 'globals)))
-                                       (validate-ast globals
-                                                     (get-undefined-vars expr globals)
-                                                     (set)
-                                                     (set)
-                                                     expr))))))
-       (env-set env
-                'ast (car result)
-                'errors (cadr result))))))
+                                          if do let letrec binding lambda app
+                                          primop-app def <error>)))
+        (lambda (env)
+          (let ((result (collect-errors (env-get env 'errors)
+                                        (lambda ()
+                                          (let ((expr (env-get env 'ast))
+                                                (globals (env-get env 'globals)))
+                                            (validate-ast globals
+                                                          (get-undefined-vars expr globals)
+                                                          (set)
+                                                          (set)
+                                                          expr))))))
+            (env-set env
+                     'ast (car result)
+                     'errors (cadr result))))
+        (schema "validate output"
+                'errors a-list?
+                'ast (ast-subset? '(const symbol
+                                          if do let letrec binding lambda app
+                                          primop-app def <error>)))))
 
 (define (get-undefined-vars expr globals)
   (set-difference (ast-node-free-vars expr) globals))