mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

first stabs as s-expression-driven transformation of GHIL

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2009-02-27 12:36:58 +01:00
parent 246be37e48
commit b106a3eddc
2 changed files with 167 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

95
module/language/ghil/compile-glil.scm
View file

@ -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)

75
module/system/base/syntax.scm
View file

@ -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))))))))))