diff options
author | Andy Wingo <wingo@pobox.com> | 2009-02-27 12:36:58 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-02-27 12:36:58 +0100 |
commit | b106a3eddc25c0bc1ef340be39a46c55962029a2 (patch) | |
tree | 9ea4e04747309eb3a61cb16238fa74a7e917e24b | |
parent | 246be37e487ec39bd945bbfdef410a5251f71adc (diff) | |
download | guile-b106a3eddc25c0bc1ef340be39a46c55962029a2.tar.gz |
first stabs as s-expression-driven transformation of GHIL
* module/language/ghil/compile-glil.scm (optimize*): Rewritten optimizer
-- not yet in use, but it's closer to the code that I'd like to write.
* module/system/base/syntax.scm (transform-record): New crazy macro,
makes GHIL a little less painful to work with.
-rw-r--r-- | module/language/ghil/compile-glil.scm | 95 | ||||
-rw-r--r-- | module/system/base/syntax.scm | 75 |
2 files changed, 167 insertions, 3 deletions
diff --git a/module/language/ghil/compile-glil.scm b/module/language/ghil/compile-glil.scm index 402e0263d..c177e9413 100644 --- a/module/language/ghil/compile-glil.scm +++ b/module/language/ghil/compile-glil.scm @@ -45,6 +45,101 @@ (ghil-env-add! parent-env v)) (ghil-env-variables env)))) +(define-macro (->ghil x) + `(,(symbol-append 'make-ghil- (car x)) + env loc + ,@(map (lambda (y) + (if (and (pair? y) (eq? (car y) 'unquote)) + (cadr y) + y)) + (cdr x)))) + +(define (optimize* x) + (transform-record (<ghil> env loc) x + ((quasiquote exp) + (define (optimize-qq x) + (cond ((list? x) (map optimize-qq x)) + ((pair? x) (cons (optimize-qq (car x)) (optimize-qq (cdr x)))) + ((record? x) (optimize x)) + (else x))) + (->ghil + (quasiquote (optimize-qq x)))) + + ((unquote exp) + (->ghil + (unquote (optimize exp)))) + + ((unquote-splicing exp) + (->ghil + (unquote-splicing (optimize exp)))) + + ((set var val) + (->ghil + (set var (optimize val)))) + + ((define var val) + (->ghil + (define var (optimize val)))) + + ((if test then else) + (->ghil + (if (optimize test) (optimize then) (optimize else)))) + + ((and exps) + (->ghil + (and (map optimize exps)))) + + ((or exps) + (->ghil + (or (map optimize exps)))) + + ((begin exps) + (->ghil + (begin (map optimize exps)))) + + ((bind vars vals body) + (->ghil + (bind vars (map optimize vals) (optimize body)))) + + ((mv-bind producer vars rest body) + (->ghil + (mv-bind (optimize producer) vars rest (optimize body)))) + + ((inline inst args) + (->ghil + (inline inst (map optimize args)))) + + ((call (proc (lambda vars (rest #f) meta body)) args) + (->ghil + (bind vars (optimize args) (optimize body)))) + + ((call proc args) + (->ghil + (call (optimize proc) (map optimize args)))) + + ((lambda vars rest meta body) + (->ghil + (lambda vars rest meta (optimize body)))) + + ((mv-call producer (consumer (lambda vars rest meta body))) + (->ghil + (mv-bind (optimize producer) vars rest (optimize body)))) + + ((mv-call producer consumer) + (->ghil + (mv-call (optimize producer) (optimize consumer)))) + + ((values values) + (->ghil + (values (map optimize values)))) + + ((values* values) + (->ghil + (values* (map optimize values)))) + + (else + (error "unrecognized GHIL" x)))) + (define (optimize x) (record-case x ((<ghil-set> env loc var val) diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm index 867720cdb..4cdd6119b 100644 --- a/module/system/base/syntax.scm +++ b/module/system/base/syntax.scm @@ -22,7 +22,7 @@ (define-module (system base syntax) #:export (%compute-initargs) #:export-syntax (define-type define-record define-record/keywords - record-case)) + record-case transform-record)) (define (symbol-trim-both sym pred) (string->symbol (string-trim-both (symbol->string sym) pred))) @@ -97,7 +97,7 @@ (printer (and (pair? name-form) (cadr name-form))) (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot)) slots)) - (stem (symbol-trim-both name (list->char-set '(#\< #\>))))) + (stem (trim-brackets name))) `(begin (define ,name (make-record-type ,(symbol->string name) ',slot-names ,@(if printer (list printer) '()))) @@ -184,7 +184,7 @@ (let ((record-type (caar clause)) (slots (cdar clause)) (body (cdr clause))) - (let ((stem (symbol-trim-both record-type (list->char-set '(#\< #\>))))) + (let ((stem (trim-brackets record-type))) `((eq? ,rtd ,record-type) (let ,(map (lambda (slot) (if (pair? slot) @@ -198,3 +198,72 @@ (if (assq 'else clauses) clauses (append clauses `((else (error "unhandled record" ,r)))))))))) + +;; Here we take the terrorism to another level. Nasty, but the client +;; code looks good. + +(define-macro (transform-record type-and-common record . clauses) + (let ((r (gensym)) + (rtd (gensym)) + (type-stem (trim-brackets (car type-and-common)))) + (define (make-stem s) + (symbol-append type-stem '- s)) + (define (further-predicates x record-stem slots) + (define (access slot) + `(,(symbol-append (make-stem record-stem) '- slot) ,x)) + (let lp ((in slots) (out '())) + (cond ((null? in) out) + ((pair? (car in)) + (let ((slot (caar in)) + (arg (cadar in))) + (cond ((symbol? arg) + (lp (cdr in) out)) + ((pair? arg) + (lp (cdr in) + (append (further-predicates (access slot) + (car arg) + (cdr arg)) + out))) + (else (lp (cdr in) (cons `(eq? ,(access slot) ',arg) + out)))))) + (else (lp (cdr in) out))))) + (define (let-clauses x record-stem slots) + (define (access slot) + `(,(symbol-append (make-stem record-stem) '- slot) ,x)) + (let lp ((in slots) (out '())) + (cond ((null? in) out) + ((pair? (car in)) + (let ((slot (caar in)) + (arg (cadar in))) + (cond ((symbol? arg) + (lp (cdr in) + (cons `(,arg ,(access slot)) out))) + ((pair? arg) + (lp (cdr in) + (append (let-clauses (access slot) + (car arg) + (cdr arg)) + out))) + (else + (lp (cdr in) out))))) + (else + (lp (cdr in) + (cons `(,(car in) ,(access (car in))) out)))))) + (define (process-clause clause) + (if (eq? (car clause) 'else) + clause + (let ((stem (caar clause)) + (slots (cdar clause)) + (body (cdr clause))) + (let ((record-type (symbol-append '< (make-stem stem) '>))) + `((and (eq? ,rtd ,record-type) + ,@(reverse (further-predicates r stem slots))) + (let ,(reverse (let-clauses r stem (append (cdr type-and-common) + slots))) + ,@(if (pair? body) body '((if #f #f))))))))) + `(let* ((,r ,record) + (,rtd (struct-vtable ,r))) + (cond ,@(let ((clauses (map process-clause clauses))) + (if (assq 'else clauses) + clauses + (append clauses `((else (error "unhandled record" ,r)))))))))) |