On 2012-03-19, at 11:17 PM, mikel evins wrote:
Marc,
We're considering building the Bard interpreter into the Nelson game framework. Bard implements CLOS-stye generic functions. I wonder if Gambit provides a way to make that more convenient than the ways I've done it in the past?
What I'd like to do if I can is define generic functions and methods as objects for which the following hold true:
- generic function is a distinct type that I can distinguish with a predicate
- the same is true of method
- I can ask a generic function for its method table and modify it
- generic function and method are both callable, like Scheme procedures
Again, I can solve these problems with various techniques, but what would be really convenient would be a way to define a callable data type. If that's not supported by the current Gambit runtime, no sweat; I can fall back to the tricks I've used before.
[I think this is of general interest to the Gambit community, so I am CCing to the Gambit mailing list and changing the subject of the message]
Generic functions can be obtained by combining a table of methods and a closure. That is, the table of methods is a free variable of the closure. To get the method table from a generic function, you have to access this free variable. Note that there is only one free variable per generic function. Accessing this free variable can be done with the (##closure-ref genfun 1) primitive (for compiled closures), and with (##vector-ref (##interp-procedure-rte genfun) 1) (for an interpreted closure). See the file genfun1.scm below.
Another approach is to represent generic functions with a type that is different from procedures, and to install an exception handler which will be invoked by the procedure call mechanism when it detects that the function position of the call is not a procedure. See the file genfun2.scm below.
The performance of both approaches could be improved by a better strategy for encoding type identifiers and the hash table of methods. I expect the approach based on closures to be the faster of the two approaches because it allocates less.
Marc
;; File: "genfun1.scm"
;;-----------------------------------------------------------------------------
(define-macro (define-generic pattern) (let ((name (car pattern)) (params (cdr pattern))) `(define ,name (let (($methods (make-table init: (lambda args (error "no method for call" (cons ',name (map ##inverse-eval args))))))) (lambda ,params ((table-ref $methods (vector ,@(map (lambda (p) `(type-identifier ,p)) params))) ,@params))))))
(define-macro (define-method pattern . body) (let ((name (car pattern)) (params (map car (cdr pattern))) (type-ids (map cadr (cdr pattern)))) `(table-set! (generic-function-methods ,name) ',(list->vector type-ids) (lambda ,params ,@body))))
(define (type-identifier obj) (cond ((number? obj) 'number) ((string? obj) 'string) ((symbol? obj) 'symbol) ((boolean? obj) 'boolean) ((null? obj) 'null) ((pair? obj) 'pair) ((vector? obj) 'vector) ((procedure? obj) 'procedure) (else 'other)))
(define (generic-function-methods proc) (cond ((##interp-procedure? proc) (##vector-ref (##interp-procedure-rte proc) 1)) ((##closure? proc) (##closure-ref proc 1)) (else (error "generic function expected"))))
;;-----------------------------------------------------------------------------
;; Tests.
(define-generic (add x y))
(define-method (add (x number) (y number)) (+ x y))
(define-method (add (x string) (y string)) (string-append x y))
(define-method (add (x string) (y number)) (string-append x (number->string y)))
(define-method (add (x number) (y string)) (string-append (number->string x) y))
(pp (table->list (generic-function-methods add)))
(pp (add 11 22)) (pp (add "foo" "bar")) (pp (add "foo" 99)) (pp (add 99 "foo")) (pp (add #t #f))
;; output: ;; ;; ((#(string number) . #<procedure #2>) ;; (#(string string) . #<procedure #3>) ;; (#(number string) . #<procedure #4>) ;; (#(number number) . #<procedure #5>)) ;; 33 ;; "foobar" ;; "foo99" ;; "99foo" ;; *** ERROR IN "genfun1.scm"@71.5 -- no method for call (add #t #f)
;;-----------------------------------------------------------------------------
==================================================================================================
;; File: "genfun2.scm"
;;-----------------------------------------------------------------------------
(define-type generic-function id: C158D90E-75CF-4F45-B7CF-EF7B9459D630 macros: name methods )
(define-macro (define-generic pattern) (let ((name (car pattern)) (params (cdr pattern))) `(define ,name (make-generic-function ',name (make-table init: (lambda args (error "no method for call" (cons ',name (map ##inverse-eval args)))))))))
(define-macro (define-method pattern . body) (let ((name (car pattern)) (params (map car (cdr pattern))) (type-ids (map cadr (cdr pattern)))) `(table-set! (generic-function-methods ,name) ',(list->vector type-ids) (lambda ,params ,@body))))
(define (type-identifier obj) (cond ((number? obj) 'number) ((string? obj) 'string) ((symbol? obj) 'symbol) ((boolean? obj) 'boolean) ((null? obj) 'null) ((pair? obj) 'pair) ((vector? obj) 'vector) ((procedure? obj) 'procedure) (else 'other)))
(current-exception-handler (let ((old-exception-handler (current-exception-handler))) (lambda (e) (if (nonprocedure-operator-exception? e) (let ((operator (nonprocedure-operator-exception-operator e)) (arguments (nonprocedure-operator-exception-arguments e))) (if (generic-function? operator) (apply (table-ref (generic-function-methods operator) (list->vector (map type-identifier arguments))) arguments) (old-exception-handler e))) (old-exception-handler e)))))
;;-----------------------------------------------------------------------------
;; Tests.
(define-generic (add x y))
(define-method (add (x number) (y number)) (+ x y))
(define-method (add (x string) (y string)) (string-append x y))
(define-method (add (x string) (y number)) (string-append x (number->string y)))
(define-method (add (x number) (y string)) (string-append (number->string x) y))
(pp (table->list (generic-function-methods add)))
(pp (add 11 22)) (pp (add "foo" "bar")) (pp (add "foo" 99)) (pp (add 99 "foo")) (pp (add #t #f))
;; output: ;; ;; ((#(string number) . #<procedure #2>) ;; (#(string string) . #<procedure #3>) ;; (#(number string) . #<procedure #4>) ;; (#(number number) . #<procedure #5>)) ;; 33 ;; "foobar" ;; "foo99" ;; "99foo" ;; *** ERROR IN "genfun2.scm"@79.5 -- no method for call (add #t #f)
;;-----------------------------------------------------------------------------
Afficher les réponses par date
On Mar 20, 2012, at 9:24 AM, Marc Feeley wrote:
On 2012-03-19, at 11:17 PM, mikel evins wrote:
Marc,
We're considering building the Bard interpreter into the Nelson game framework. Bard implements CLOS-stye generic functions. I wonder if Gambit provides a way to make that more convenient than the ways I've done it in the past?
What I'd like to do if I can is define generic functions and methods as objects for which the following hold true:
- generic function is a distinct type that I can distinguish with a predicate
- the same is true of method
- I can ask a generic function for its method table and modify it
- generic function and method are both callable, like Scheme procedures
Again, I can solve these problems with various techniques, but what would be really convenient would be a way to define a callable data type. If that's not supported by the current Gambit runtime, no sweat; I can fall back to the tricks I've used before.
[I think this is of general interest to the Gambit community, so I am CCing to the Gambit mailing list and changing the subject of the message]
Generic functions can be obtained by combining a table of methods and a closure. That is, the table of methods is a free variable of the closure. To get the method table from a generic function, you have to access this free variable. Note that there is only one free variable per generic function. Accessing this free variable can be done with the (##closure-ref genfun 1) primitive (for compiled closures), and with (##vector-ref (##interp-procedure-rte genfun) 1) (for an interpreted closure). See the file genfun1.scm below.
Another approach is to represent generic functions with a type that is different from procedures, and to install an exception handler which will be invoked by the procedure call mechanism when it detects that the function position of the call is not a procedure. See the file genfun2.scm below.
The performance of both approaches could be improved by a better strategy for encoding type identifiers and the hash table of methods. I expect the approach based on closures to be the faster of the two approaches because it allocates less.
Thanks very much, Marc. This is very helpful.
I see you dispatch via cond:
(define (type-identifier obj) (cond ((number? obj) 'number) ((string? obj) 'string) ((symbol? obj) 'symbol) ((boolean? obj) 'boolean) ((null? obj) 'null) ((pair? obj) 'pair) ((vector? obj) 'vector) ((procedure? obj) 'procedure) (else 'other)))
When I was writing the Clojure->Gambit polymorphic dispatch I reached immediately for case and branched on the numerical value of the type/subtype id assuming I'd get fast constant time dispatch. This cond as you've written would be a linear search, would it not? Or is Gambit able to see that these predicates can be dispatched to in constant time via type tag info?
On 2012-03-20, at 4:52 PM, Nathan Sorenson wrote:
I see you dispatch via cond:
(define (type-identifier obj) (cond ((number? obj) 'number) ((string? obj) 'string) ((symbol? obj) 'symbol) ((boolean? obj) 'boolean) ((null? obj) 'null) ((pair? obj) 'pair) ((vector? obj) 'vector) ((procedure? obj) 'procedure) (else 'other)))
When I was writing the Clojure->Gambit polymorphic dispatch I reached immediately for case and branched on the numerical value of the type/subtype id assuming I'd get fast constant time dispatch. This cond as you've written would be a linear search, would it not? Or is Gambit able to see that these predicates can be dispatched to in constant time via type tag info?
Yes it would be a linear search. As I said, the code can be optimized in various ways. I wrote it that way so that it would be understandable.
Below is a more efficient version of the procedure type-identifier which uses the ##type and ##subtype low-level primitives (these respectively extract the low tag bits of the reference, and the tag bits in memory allocated objects). For added speed, the procedure type-tag could be used directly (to give a numerical identifier). For multiple dispatch the numerical identifiers could be combined with addition and multiplication to construct a single type signature identifier which indexes a method *vector*. I guess that would work well for 1 and 2 parameter generic functions (beyond that the method vector would be too big to be practical). Moreover, support for user defined types and classes is an added complexity.
Marc
(include "~~lib/_gambit#.scm")
(define (type-identifier obj) (vector-ref type-identifier-vector (type-tag obj)))
(define (type-tag obj) (let ((t (##type obj))) (cond ((fx= t (macro-type-fixnum)) 32) ((fx= t (macro-type-special)) (cond ((null? obj) 33) ((char? obj) 34) ((boolean? obj) 35) (else 36))) (else (##subtype obj)))))
(define type-identifier-vector ;; NOTE: the assignment of tags to types may be different in future versions of Gambit '#(vector pair ratnum cpxnum structure boxvalues meroon jazz symbol keyword frame continuation promise weak procedure return type16 type17 foreign string s8vector u8vector s16vector u16vector s32vector u32vector f32vector s64vector u64vector f64vector flonum bignum fixnum null char boolean other))
(pp (map (lambda (obj) (list obj (type-identifier obj))) (list '#(11 22) '(11 22) 1/2 1+2i (open-input-string "") (box 11) (values 11 22) 'foo foo: (continuation-capture (lambda (k) k)) (delay 10) (make-will (cons 11 22) pp) (lambda (x) x) "hello" (s8vector) (u8vector) (s16vector) (u16vector) (s32vector) (u32vector) (f32vector) (s64vector) (u64vector) (f64vector) 3.14 12345678901234567890 11 '() #\x #t (void))))
;; output: ;; ;; ((#(11 22) vector) ;; ((11 22) pair) ;; (1/2 ratnum) ;; (1+2i cpxnum) ;; (#<input-port #2 (string)> structure) ;; (#&11 boxvalues) ;; (#<unknown> boxvalues) ;; (foo symbol) ;; (foo: keyword) ;; (#<continuation #3> continuation) ;; (#<promise #4> promise) ;; (#<will #5> weak) ;; (#<procedure #6> procedure) ;; ("hello" string) ;; (#s8() s8vector) ;; (#u8() u8vector) ;; (#s16() s16vector) ;; (#u16() u16vector) ;; (#s32() s32vector) ;; (#u32() u32vector) ;; (#f32() f32vector) ;; (#s64() s64vector) ;; (#u64() u64vector) ;; (#f64() f64vector) ;; (3.14 flonum) ;; (12345678901234567890 bignum) ;; (11 fixnum) ;; (() null) ;; (#\x char) ;; (#t boolean) ;; (#!void other))