From f65880b27ea51be81641c97a76d9d44b217dbae2 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Tue, 14 Feb 2023 21:09:35 -0500 Subject: Fix overload issues enough that the 9-patch shader compiles. --- chickadee/graphics/seagull.scm | 167 +++++++++++++++++++++++------------------ 1 file changed, 92 insertions(+), 75 deletions(-) diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index cc1df7f..4e271ff 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -37,6 +37,15 @@ ;; - No closures ;; - No recursion ;; +;; TODO: +;; - Loops +;; - (define ...) form +;; - Scheme shader type -> GLSL struct translation +;; - Dead code elimination (error when a uniform is eliminated) +;; - User defined structs +;; - Multiple GLSL versions +;; - Better error messages (especially around type predicate failure) +;; ;;; Code: (define-module (chickadee graphics seagull) #:use-module (chickadee graphics shader) @@ -67,12 +76,6 @@ ;; in a program that is one step closer to being directly emitted to ;; GLSL code. -;; TODO: -;; - Loops -;; - Scheme shader type -> GLSL struct translation -;; - Dead code elimination (error when a uniform is eliminated) -;; - Multiple GLSL versions - ;;; ;;; Compiler helpers @@ -829,17 +832,23 @@ `(top-level ,new-bindings ,exp)))) (define (hoist-functions* exp) - (define-values (exp* env) + (define-values (exp* function-env) (hoist-functions exp)) (define top-level-vars - (append (env-names env) '(+ - * /))) + (append (env-names function-env) + (map (match-lambda + ((_ _ name) name)) + (match exp* + (('top-level bindings _) + bindings) + (_ '()))))) (env-for-each (lambda (name exp) (check-free-variables exp '() top-level-vars)) - env) + function-env) (define bindings (env-map (lambda (name func) `(function ,name ,func)) - env)) + function-env)) (maybe-merge-top-levels bindings exp*)) @@ -1892,7 +1901,7 @@ (((? top-level-qualifier? qualifier) type-name name _) (list qualifier type-name name)) (('function _ name exp) - `(function ,name ,exp))) + `(function ,name ,(apply-substitutions-to-exp exp combined-subs)))) qualifiers type-names names exps)) (values (texp (texp-types body*) `(top-level ,bindings* ,body*)) @@ -2181,72 +2190,64 @@ ;; of non-quantified function type specifications, one for each unique ;; type of call in the program. -;; Check if the substitutions in a and b do not contain -;; contradictions. -(define (consistent? a b) - (every (match-lambda - ((from . to) - (let ((other (assq-ref b from))) - (or (not other) (equal? to other))))) - a)) +(define (find-signatures:list name texps) + (append-map (lambda (texp) + (find-signatures name texp)) + texps)) -;; Compute all the valid permutations of substitutions that a -;; predicate could produce. -(define (possible-substitutions pred structs) - (match pred - (#t '()) - (('substitute from to) - (list (list (cons from to)))) - (('= a b) - (list (list (cons a b)))) - (('struct-field struct-var field field-var) - (filter-map (lambda (struct) - (let ((field-type (struct-type-ref struct field))) - (and field-type - (list (cons struct-var struct) - (cons field-var field-type))))) - structs)) - (('struct-field struct-var field field-var) - (filter-map (lambda (struct) - (let ((field-type (struct-type-ref struct field))) - (and field-type - (list (cons struct-var struct) - (cons field-var field-type))))) - structs)) - (('or preds ...) - (concatenate (map (lambda (pred) - (possible-substitutions pred structs)) - preds))) - (((or 'and 'list) preds ...) - (let loop ((in (map (lambda (pred) - (possible-substitutions pred structs)) - preds))) - (match in - (() '()) - ((options . rest) - (define rest-options (loop rest)) - (append-map (lambda (a) - (if (null? rest-options) - (list a) - (filter-map (lambda (b) - (and (consistent? a b) - (compose-substitutions a b))) - rest-options))) - options))))))) - -(define (find-structs exp) +(define (find-signatures:if name predicate consequent alternate) + (append (find-signatures name predicate) + (find-signatures name consequent) + (find-signatures name alternate))) + +(define (find-signatures:let name binding-texps body) + (append (find-signatures:list name binding-texps) + (find-signatures name body))) + +(define (find-signatures:array-ref name array index) + (append (find-signatures name array) + (find-signatures name index))) + +(define (find-signatures name texp) + (match (texp-exp texp) + ((or (? immediate?) (? symbol?)) + '()) + (('if predicate consequent alternate) + (find-signatures:if name predicate consequent alternate)) + (('let ((_ exps) ...) body) + (find-signatures:let name exps body)) + (('values exps ...) + (find-signatures:list name exps)) + (('primcall _ args ...) + (find-signatures:list name args)) + (('call operator args ...) + (cons (if (eq? (texp-exp operator) name) + (function-type (map single-type args) + (texp-types texp))) + (find-signatures:list name args))) + (('struct-ref struct _) + (find-signatures name struct)) + (('array-ref array index) + (find-signatures:array-ref name array index)) + (('outputs (_ exps) ...) + (find-signatures:list name exps)) + (_ (error "uh oh" texp)))) + +(define (vars->subs exp env) (match exp - ((? struct-type?) - (list exp)) - ((exps ...) - (append-map find-structs exps)) + (('t ((? variable-type? tvar)) (? symbol? name)) + (list (cons tvar (lookup name env)))) + ((head . rest) + (delete-duplicates + (append (vars->subs head env) + (vars->subs rest env)))) (_ '()))) (define (resolve-overloads program) ;; Find all of the struct types used in the program. They will be ;; used to generate overloaded functions that take one or more ;; structs as arguments. - (define structs (delete-duplicates (find-structs program))) + ;;(define structs (delete-duplicates (find-structs program))) (match program (('t types ('top-level bindings body)) (define bindings* @@ -2256,16 +2257,32 @@ ((('function name ('t ((? type-scheme? type)) func)) . rest) (define qtype (type-scheme-ref type)) (define func-type (qualified-type-ref qtype)) - (append (map (lambda (subs) + (append (map (lambda (call-type) + (define subs + (unify func-type call-type)) (define type* (apply-substitutions-to-type func-type subs)) + (define params + (match func + (('lambda (params ...) _) + params))) + (define env + (fold extend-env (empty-env) params + (function-type-parameters type*))) + (define subs* + (compose-substitutions subs + (vars->subs func env))) (define func* - (apply-substitutions-to-exp func subs)) + (apply-substitutions-to-exp func subs*)) `(function ,name (t (,type*) ,func*))) (delete-duplicates - (possible-substitutions - (qualified-type-predicate qtype) - structs))) + (find-signatures name body) + ;; (append (append-map (match-lambda + ;; (('function name lambda*) + ;; (find-signatures name lambda*))) + ;; rest) + ;; (find-signatures name body)) + )) (loop rest))) ((binding . rest) (cons binding (loop rest)))))) @@ -2415,7 +2432,7 @@ (emit:mov lhs rhs port (+ level 1))) if-temps consequent-temps) (indent level port) - (display "else {\n" port) + (display "} else {\n" port) (define alternate-temps (emit-glsl alternate version port (+ level 1))) (for-each (lambda (lhs rhs) -- cgit v1.2.3