summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-02-27 12:36:58 +0100
committerAndy Wingo <wingo@pobox.com>2009-02-27 12:36:58 +0100
commitb106a3eddc25c0bc1ef340be39a46c55962029a2 (patch)
tree9ea4e04747309eb3a61cb16238fa74a7e917e24b
parent246be37e487ec39bd945bbfdef410a5251f71adc (diff)
downloadguile-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.scm95
-rw-r--r--module/system/base/syntax.scm75
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))))))))))