bind-it.rkt

#|
building syntax objects
cpu time: 106 real time: 112 gc time: 45
expanding
cpu time: 16063 real time: 17360 gc time: 2152

building syntax objects 2
cpu time: 116 real time: 126 gc time: 50
expanding
cpu time: 15898 real time: 16583 gc time: 2231

building syntax objects 2.5
cpu time: 93 real time: 97 gc time: 31
expanding
cpu time: 3626 real time: 3726 gc time: 999

building syntax objects 3
cpu time: 89 real time: 92 gc time: 29
expanding
cpu time: 14848 real time: 15569 gc time: 2062

building syntax objects 4
cpu time: 25 real time: 26 gc time: 1
expanding
cpu time: 328 real time: 337 gc time: 115

building syntax objects 5
cpu time: 46 real time: 48 gc time: 12
expanding
cpu time: 937 real time: 970 gc time: 284
|#

#lang racket/base

(require (for-syntax racket/base racket/syntax))

(begin-for-syntax
  (define (bind-fvars s n tail)
    (printf "\nbuilding syntax objects\n")
    (time
     #`(let-syntax
           #,(for/list ([i (in-range 0 n)])
               (with-syntax ([fvar (syntax-local-introduce (format-id #f "fv~a" i))]
                             [offset i]
                             [stack s])
                 #`[fvar (make-set!-transformer
                          (lambda (stx)
                            (syntax-case stx ()
                              [(set! id v)
                               #`(vector-set! stack offset v)]
                              [id (identifier? #'id)
                                  #`(vector-ref stack offset)])))]))
         #,tail)))

  (define (bind-fvars2 s n tail)
    (printf "\nbuilding syntax objects 2\n")
    (time
     #`(let-syntax
           #,(for/list ([i (in-range 0 n)])
               (with-syntax ([fvar (syntax-local-introduce (format-id #f "fv~a" i))]
                             [offset i]
                             [stack s])
                 #`[fvar (#%app
                          make-set!-transformer
                          (#%plain-lambda
                           (stx)
                           (syntax-case stx ()
                             [(set! id v)
                              #`(#%plain-app vector-set! stack 'offset v)]
                             [id (identifier? #'id)
                                 #`(#%plain-app vector-ref stack 'offset)])))]))
         #,tail)))

  (define (bind-fvars2.5 s n tail)
    (printf "\nbuilding syntax objects 2.5\n")
    (time
     #`(let-syntax
           #,(for/list ([i (in-range 0 n)])
               (with-syntax ([fvar (syntax-local-introduce (format-id #f "fv~a" i))]
                             [offset i]
                             [stack s])
                 #`[fvar (#%app
                          make-set!-transformer
                          (#%plain-lambda
                           (stx)
                           (if (#%plain-app pair? (#%plain-app syntax-e stx))
                               (#%plain-app
                                datum->syntax
                                (quote-syntax here)
                                (#%plain-app list
                                             '#%plain-app
                                             'vector-set!
                                             'stack
                                             ''offset
                                             (caddr (#%plain-app syntax-e stx))))
                               #'(#%plain-app vector-ref stack 'offset))))]))
         #,tail)))

  (define (bind-fvars3 s n tail)
    (printf "\nbuilding syntax objects 3\n")
    (time
     #`(letrec-syntaxes+values
           #,(for/list ([i (in-range 0 n)])
               (with-syntax ([fvar (syntax-local-introduce (format-id #f "fv~a" i))]
                             [offset i]
                             [stack s])
                 #`[(fvar) (make-set!-transformer
                            (lambda (stx)
                              (syntax-case stx ()
                                [(set! id v)
                                 #`(vector-set! stack offset v)]
                                [id (identifier? #'id)
                                    #`(vector-ref stack offset)])))]))
         ()
         #,tail)))

  (define (bind-fvars4 s n tail)
    (printf "\nbuilding syntax objects 4\n")
    (time
     (with-syntax ([stack s]
                   [len n])
       #`(let-syntaxes
          ([#,(for/list ([i (in-range 0 n)])
                (syntax-local-introduce (format-id #f "fv~a" i)))
            (apply
             values
             (for/list ([i (in-range 0 len)])
               (with-syntax ([offset i])
                 (make-set!-transformer
                  (lambda (stx)
                    (syntax-case stx ()
                      [(set! id v)
                       #`(vector-set! stack offset v)]
                      [id (identifier? #'id)
                          #`(vector-ref stack offset)]))))))])
          #,tail))))

  (define (delegate-fvar stack offset)
    (make-set!-transformer
     (lambda (stx)
       (syntax-case stx ()
         [(set! id v)
          #`(vector-set! #,stack '#,offset v)]
         [id (identifier? #'id)
             #`(vector-ref #,stack '#,offset)]))))

  (define (bind-fvars5 s n tail)
    (printf "\nbuilding syntax objects 5\n")
    (time
     #`(let-syntax
           #,(for/list ([i (in-range 0 n)])
               (with-syntax ([fvar (syntax-local-introduce (format-id #f "fv~a" i))]
                             [offset i]
                             [stack s])
                 #`[fvar (delegate-fvar #'stack offset)]))
         #,tail)))
  )

(define-syntax (make-mod stx)
  (define do-bind
    (hash-ref (hash 'bind-fvars bind-fvars
                    'bind-fvars2 bind-fvars2
                    'bind-fvars2.5 bind-fvars2.5
                    'bind-fvars3 bind-fvars3
                    'bind-fvars4 bind-fvars4
                    'bind-fvars5 bind-fvars5)
              (cadr (syntax->datum stx))))
  (define body
    (do-bind
     #'mem
     10000
     (datum->syntax
      stx
      '(begin
         (set! fv0 8)
         (set! fv1 8)
         (+ fv0 fv1)))))
  (printf "expanding\n")
  #`(let ([mem (make-vector 10000)])
      #,body))

(define-namespace-anchor here)
(current-namespace (namespace-anchor->namespace here))

(time
 (void
  (eval
   '(make-mod bind-fvars))))

(time
 (void
  (eval
   '(make-mod bind-fvars2))))

(time
 (void
  (eval
   '(make-mod bind-fvars2.5))))

(time
 (void
  (eval
   '(make-mod bind-fvars3))))

(time
 (void
  (eval
   '(make-mod bind-fvars4))))

(time
 (void
  (eval
   '(make-mod bind-fvars5))))

meow.rkt

#lang racket
(require (for-syntax racket/syntax))

#|
1,000 fvars; let-syntax implementation
cpu time: 1162 real time: 1165 gc time: 156

10,000 fvars; let-syntax implementation
cpu time: 10928 real time: 10964 gc time: 1374

1,000 fvars; let implementation
cpu time: 20 real time: 20 gc time: 3

10,000 fvars; let implementation
cpu time: 225 real time: 225 gc time: 54
|#

(begin-for-syntax
  (define current-fvars (make-parameter 10000))

  (define (bind-fvars s n tail)
    #`(let-syntax
          #,(for/list ([i (in-range 0 n)])
              (with-syntax ([fvar (syntax-local-introduce (format-id #f "fv~a" i))]
                            [offset i]
                            [stack s])
                #`[fvar (make-set!-transformer
                         (lambda (stx)
                           (syntax-case stx ()
                             [(set! id v)
                              #`(vector-set! stack offset v)]
                             [id (identifier? #'id)
                                 #`(vector-ref stack offset)])))]))
        #,tail)))

(define-syntax (my-module stx)
  (syntax-case stx ()
    [(_ e ...)
     (with-syntax ([s #'stack])
       #`(let ([s (make-vector #,(current-fvars) (void))])
           #,(bind-fvars #'s (current-fvars) #`(begin e ...))))]))

(define-namespace-anchor a)

(displayln "1,000 fvars; let-syntax implementation")

(time
 (eval
  '(begin
     (begin-for-syntax
       (current-fvars 1000))
     (my-module
      (set! fv0 8)
      (set! fv1 8)
      (+ fv0 fv1)))
  (namespace-anchor->namespace a)))

(displayln "10,000 fvars; let-syntax implementation")

(time
 (eval
  '(begin
     (begin-for-syntax
       (current-fvars 10000))
     (my-module
      (set! fv0 8)
      (set! fv1 8)
      (+ fv0 fv1)))
  (namespace-anchor->namespace a)))

(define-for-syntax (bind-fvars2 n tail)
  #`(let #,(for/list ([i (in-range 0 n)])
             (with-syntax ([fvar (syntax-local-introduce (format-id #f "fv~a" i))])
               #`[fvar (void)]))
      #,tail))

(define-syntax (my-module2 stx)
  (syntax-case stx ()
    [(_ e ...)
     (bind-fvars2 (current-fvars) #`(begin e ...))]))

;; expansion time increases with the number of let bindings, but not nearly as bad
;; expansion time seems to be 1ms per fvar, i.e., per let-syntax?

(displayln "1,000 fvars; let implementation")

(time
 (eval
  '(begin
     (begin-for-syntax
       (current-fvars 1000))
     (my-module2
      (set! fv0 8)
      (set! fv1 8)
      (+ fv0 fv1)))
  (namespace-anchor->namespace a)))

(displayln "10,000 fvars; let implementation")
(time
 (eval
  '(begin
     (begin-for-syntax
       (current-fvars 10000))
     (my-module2
      (set! fv0 8)
      (set! fv1 8)
      (+ fv0 fv1)))
  (namespace-anchor->namespace a)))