[plt-scheme] Polymorphic Structure Types

From: Andre van Tonder (andre at het.brown.edu)
Date: Tue Apr 22 10:18:32 EDT 2003

On Tue, 22 Apr 2003, Eli Barzilay wrote:

> 1. Swindle did that for ages...  (Sorry, but I couldn't resist, I know
>    that you know...)  And it is not as heavyweight as it seems.

I love Swindle.  It's a great piece of software to have available in
Scheme and offers a lot.  But I am having some problems with its
performance on small examples.  I have a stupid little benchmark below -
but the Swindle code is more than ten times slower.  Am I making some
obvious mistake?

Regards
Andre

(require (lib "pattern-dispatch.ss" "mzscheme"))
(require (lib "poly-records.ss" "mzscheme"))

(define-record point x y)
(define-record color r g b)
(define-record colored-point (point color) x y r g b tag)

(define a-point (make-point 50 70))
(define a-colored-point (make-colored-point 10 20 1 2 3 'a-tag))

(define (show ($ point x y)) (list x y))
(define (show ($ color r g b)) (list r g b))
(define (show ($ colored-point x y r g b tag)) (list x y r g b tag))

(show a-point)
(show a-colored-point)

(time (let loop ([i 100000]) 
      (unless (= i 0) 
        
        (color?  a-colored-point)   
        (point-x a-point)            
        (point-x a-colored-point)    
        (color-g a-colored-point) 
        (show a-point)
        (show a-colored-point)

        (loop (- i 1))))) 

(require (lib "swindle.ss" "swindle"))

(-defclass-autoaccessors-naming- :slot)
(-defclass-auto-initargs- (:auto #t))

(defclass <point> () x y)
(defclass <color> () r g b)
(defclass <colored-point> (<point> <color>) tag)

(define a-point (make-point 50 70))
(define a-colored-point (make-colored-point 1 2 3 10 20 'a-tag))


(defmethod (show1 (p <point>)) (list (x p) (y p)))
(defmethod (show1 (c <color>)) (list (r c) (g c) (b c)))
(defmethod (show1 (cp <colored-point>)) (list (x cp) (y cp) 
                                             (r cp) (g cp)
                                             (b cp) (tag cp)))

(show1 a-point)
(show1 a-colored-point)

(time (let loop ([i 100000]) 
      (unless (= i 0) 
        
        (color?  a-colored-point)    
        (x a-point)           
        (x a-colored-point)    
        (g a-colored-point)   
        (show1 a-point)
        (show1 a-colored-point)

        (loop (- i 1))))) 
-------------- next part --------------
(module pattern-dispatch mzscheme

  

  (provide (all-from-except mzscheme

                            lambda

                            case-lambda

                            define))

  

  (provide (rename define*      define)

           (rename case-define* case-define)

           (rename lambda*      lambda)

           (rename case-lambda* case-lambda))

  

  (require-for-syntax (lib "list.ss"))

  

  (require (lib "etc.ss")

           (lib "match.ss"))

            

  

  ;; Execute body, catching all errors and returning `#f' if one occurred.

  ;; If no errors, return value of body.

  ;; Snippet copied from Eli Barzilay's code.  

  

  (define-syntax no-errors

    (syntax-rules ()

      [(_ <body>)

       (with-handlers ((void (lambda (x) #f))) <body>)]))

  

  

  (define-syntax-set (define* case-define* lambda* case-lambda*

                      case-define-pat case-lambda-pat)

    

    ;; define* expands to define in all the non-pattern cases.

    

    (define define*/proc

      (lambda (stx)

        (syntax-case stx ()

          [(_ (<f> . <arglist>) <expr> ...)  

           (andmap valid-symbol? (improper->proper (syntax-object->datum #'<arglist>)))

           #'(define (<f> . <arglist>) <expr> ...)]

          [(_ (<f> . <arglist>) <expr> ...)                  

           #'(case-define-pat [(<f> . <arglist>) <expr> ...])]

          [(_ <identifier> <expr> ...)              

           #'(define <identifier> <expr> ...)]))) 

    

    

    (define case-define*/proc

      (lambda (stx)

        (syntax-case stx ()

          [(_ [<expr> ...])                         ;; Single declaration - handle as 

           #'(define* <expr> ...)]                  ;; above.

          [(_ [(<f> . <arglist>) <expr> ...]

              ...)                  

           #'(case-define-pat [(<f> . <arglist>) <expr> ...]

                              ...)])))          

            

    

    (define case-define-pat/proc

      (lambda (stx)

        (syntax-case stx ()

          [(_ [(<f> . <arglist>) <expr> ...] ...)        

           (with-syntax ([<name> (car (syntax-e #'(<f> ...)))])

             (let ([last-pat (car (reverse (syntax-object->datum #'(<arglist> ...))))])

               (if (andmap symbol? (improper->proper last-pat))   

                   #'(define <name> (case-lambda* [<arglist> <expr> ...] ...))

                   (syntax-case #'(<arglist> ...) ()

                     [((<arg>) ...)     ;; Avoid "apply" if single argument

                      #'(begin                                   

                          (define <name> (if (no-errors (procedure? <name>))

                                             (let ([next-method <name>])

                                               (case-lambda* [<arglist> <expr> ...]

                                                             ...

                                                             [(x) (next-method x)]))

                                             (case-lambda* [(<arg>) <expr> ...] ...))))]

                     [_ 

                      #'(begin                                                             

                          (define <name> (if (no-errors (procedure? <name>))

                                             (let ([next-method <name>])

                                               (case-lambda* [<arglist> <expr> ...]

                                                             ...

                                                             [x (apply next-method x)]))

                                             (case-lambda* [<arglist> <expr> ...] ...))))]))))])))

    

    

    ;; lambda* expands to lambda in all the non-pattern cases.

    

    (define lambda*/proc

      (lambda (stx)

        (syntax-case stx ()

          [(_ <arglist> <expr> ...) 

           (if (andmap valid-symbol? (improper->proper (syntax-object->datum #'<arglist>)))   

               #'(lambda <arglist> <expr> ...)

               #'(case-lambda-pat [<arglist> <expr> ...]))])))

    

    

    ;; case-lambda* expands to case-lambda in all the non-pattern cases.

    

    (define case-lambda*/proc

      (lambda (stx)

        (syntax-case stx ()

          [(_ [<arglist> <expr> ...] ...)

           (if (andmap valid-symbol? (apply append 

                                            (map improper->proper 

                                                 (syntax-object->datum #'(<arglist> ...)))))

               #'(case-lambda [<arglist> <expr> ...] ...)

               #'(case-lambda-pat [<arglist> <expr> ...] ...))])))   

    

    

    (define (case-lambda-pat/proc stx)

      (syntax-case stx ()

        [(_ [(<pat>) <expr> ...] ...)               ;; Single argument handled separately 

         #'(match-lambda [<pat> <expr> ...] ...)]   ;; (match-lambda more efficient)

        [(_ [<arglist> <expr> ...] ...)

         #'(match-lambda* [<arglist> <expr> ...] ...)]))

        

    

    (define (improper->proper x)

      (cond [(null? x)       null]

            [(not (pair? x)) (list x)]

            [else            (cons (car x) 

                                   (improper->proper (cdr x)))]))

    

    (define (valid-symbol? x)

      (and (symbol? x)

           (not (eq? x '_))))

    

    ) ;; end syntax-set

  ) ;; end module

Posted on the users mailing list.