Changeset 11988 in project


Ignore:
Timestamp:
09/24/08 06:04:47 (12 years ago)
Author:
Kon Lovett
Message:

Specialized source for ref & update operations. An attempt to compensate for the closure heavy SRFI 69 API.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • chicken/trunk/srfi-69.scm

    r11960 r11988  
    99;
    1010;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
    11 ;     disclaimer. 
     11;     disclaimer.
    1212;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
    13 ;     disclaimer in the documentation and/or other materials provided with the distribution. 
     13;     disclaimer in the documentation and/or other materials provided with the distribution.
    1414;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
    15 ;     products derived from this software without specific prior written permission. 
     15;     products derived from this software without specific prior written permission.
    1616;
    1717; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
    … …  
    4848
    4949(private srfi-69
    50   unbound-value-thunk
    5150  %object-uid-hash %eq?-hash %eqv?-hash %equal?-hash
    52   %hash-table-copy %hash-table-ref %hash-table-update! %hash-table-merge!
     51  %hash-table-copy %hash-table-merge!
    5352  %hash-table-for-each %hash-table-fold
    54   hash-table-canonical-length hash-table-rehash )
     53  hash-table-canonical-length
     54  %hash-table-rehash! %hash-table-check-resize!
     55  %hash-table-update!/default )
    5556
    5657(declare
    5758  (hide
    58     unbound-value-thunk
    5959    %object-uid-hash %eq?-hash %eqv?-hash %equal?-hash
    60     %hash-table-copy %hash-table-ref %hash-table-update! %hash-table-merge!
     60    %hash-table-copy %hash-table-merge!
    6161    %hash-table-for-each %hash-table-fold
    62     hash-table-canonical-length hash-table-rehash) )
     62    hash-table-canonical-length
     63    %hash-table-rehash! %hash-table-check-resize!
     64    %hash-table-update!/default ) )
    6365
    6466(cond-expand
    … …  
    7577
    7678(register-feature! 'srfi-69)
    77 
    78 
    79 ;;; Unbound Value:
    80 
    81 ;; This only works because of '(no-bound-checks)'
    82 
    83 (define-macro ($unbound-value)
    84  '(##sys#slot '##sys#arbitrary-unbound-symbol 0) )
    85 
    86 (define unbound-value-thunk (lambda () ($unbound-value)))
    87 
    88 (define-macro ($unbound? ?val)
    89   `(eq? ($unbound-value) ,?val) )
    9079
    9180
    … …  
    325314(define (%equal?-hash obj)
    326315
    327   ; Recurse into some portion of the vector's slots 
     316  ; Recurse into some portion of the vector's slots
    328317  (define (vector-hash obj seed depth start)
    329318    (let ([len (##sys#size obj)])
    … …  
    608597    (thunk) ) )
    609598
     599;; %hash-table-rehash!:
     600
     601(define (%hash-table-rehash! vec1 vec2 hash)
     602  (let ([len1 (##sys#size vec1)]
     603        [len2 (##sys#size vec2)] )
     604    (do ([i 0 (fx+ i 1)])
     605        [(fx>= i len1)]
     606      (let loop ([bucket (##sys#slot vec1 i)])
     607        (unless (null? bucket)
     608          (let* ([pare (##sys#slot bucket 0)]
     609                 [key (##sys#slot pare 0)]
     610                 [hshidx (hash key len2)] )
     611            (##sys#setslot vec2 hshidx
     612                           (cons (cons key (##sys#slot pare 1)) (##sys#slot vec2 hshidx)))
     613            (loop (##sys#slot bucket 1)) ) ) ) ) ) )
     614
     615;; %hash-table-resize!:
     616
     617(define (%hash-table-resize! ht vec len)
     618  (let* ([deslen (fxmin hash-table-max-length (fx* len hash-table-new-length-factor))]
     619         [newlen (hash-table-canonical-length hash-table-prime-lengths deslen)]
     620         [vec2 (make-vector newlen '())] )
     621    (%hash-table-rehash! vec vec2 (##sys#slot ht 4))
     622    (##sys#setslot ht 1 vec2) ) )
     623
     624;; %hash-table-check-resize!:
     625
     626#; ;UNUSED
     627(define %hash-table-check-resize!
     628       ; Note that these are standard integrations!
     629  (let ([floor floor]
     630        [inexact->exact inexact->exact]
     631        [* *] )
     632    (lambda (ht newsiz)
     633      (let ([vec (##sys#slot ht 1)]
     634            [min-load (##sys#slot ht 5)]
     635            [max-load (##sys#slot ht 6)] )
     636        (let ([len (##sys#size vec)] )
     637          (let ([min-load-len (inexact->exact (floor (* len min-load)))]
     638                [max-load-len (inexact->exact (floor (* len max-load)))] )
     639            (if (and (fx< len hash-table-max-length)
     640                     (fx<= min-load-len newsiz) (fx<= newsiz max-load-len))
     641                (%hash-table-resize! ht vec len) ) ) ) ) ) ) )
     642
     643(define-inline (%hash-table-check-resize! ht newsiz)
     644  (let ([vec (##sys#slot ht 1)]
     645        [min-load (##sys#slot ht 5)]
     646        [max-load (##sys#slot ht 6)] )
     647    (let ([len (##sys#size vec)] )
     648      (let ([min-load-len (inexact->exact (floor (* len min-load)))]
     649            [max-load-len (inexact->exact (floor (* len max-load)))] )
     650        (if (and (fx< len hash-table-max-length)
     651                 (fx<= min-load-len newsiz) (fx<= newsiz max-load-len))
     652          (%hash-table-resize! ht vec len) ) ) ) ) )
     653
    610654;; hash-table-copy:
    611655
    … …  
    642686;; Modified for ht props min & max load.
    643687
    644 (define (hash-table-rehash vec1 vec2 hash)
    645   (let ([len1 (##sys#size vec1)]
    646         [len2 (##sys#size vec2)] )
    647     (do ([i 0 (fx+ i 1)])
    648         [(fx>= i len1)]
    649       (let loop ([bucket (##sys#slot vec1 i)])
    650         (unless (null? bucket)
    651           (let* ([pare (##sys#slot bucket 0)]
    652                  [key (##sys#slot pare 0)]
    653                  [hshidx (hash key len2)] )
    654             (##sys#setslot vec2 hshidx
    655                            (cons (cons key (##sys#slot pare 1))
    656                                  (##sys#slot vec2 hshidx)))
    657             (loop (##sys#slot bucket 1)) ) ) ) ) ) )
    658 
    659 (define %hash-table-update!
    660   (let ([core-eq? eq?]
    661         [floor floor] )
    662     (lambda (ht key func thunk)
    663       (let ([hash (##sys#slot ht 4)]
    664             [test (##sys#slot ht 3)]
    665             [newsiz (fx+ (##sys#slot ht 2) 1)]
    666             [min-load (##sys#slot ht 5)]
    667             [max-load (##sys#slot ht 6)] )
    668         (let re-enter ()
    669           (let* ([vec (##sys#slot ht 1)]
    670                  [len (##sys#size vec)] )
    671             (let ([min-load-len (inexact->exact (floor (* len min-load)))]
    672                   [max-load-len (inexact->exact (floor (* len max-load)))]
    673                   [hshidx (hash key len)] )
    674               ; Need to resize table?
    675               (if (and (fx< len hash-table-max-length)
    676                        (fx<= min-load-len newsiz) (fx<= newsiz max-load-len))
    677                   ; then resize the table:
    678                   (let ([vec2 (make-vector
    679                                (hash-table-canonical-length
    680                                 hash-table-prime-lengths
    681                                 (fxmin hash-table-max-length
    682                                        (fx* len hash-table-new-length-factor)))
    683                                '())])
    684                     (hash-table-rehash vec vec2 hash)
    685                     (##sys#setslot ht 1 vec2)
    686                     (re-enter) )
    687                   ; else update the table:
    688                   (let ([bucket0 (##sys#slot vec hshidx)])
    689                     (if (eq? core-eq? test)
    690                         ; Fast path (eq? is rewritten by the compiler):
    691                         (let loop ([bucket bucket0])
    692                           (cond [(null? bucket)
    693                                  (let ([val (func (thunk))])
    694                                    (##sys#setslot vec hshidx (cons (cons key val) bucket0))
    695                                    (##sys#setislot ht 2 newsiz)
    696                                    val) ]
    697                                 [else
    698                                  (let ([pare (##sys#slot bucket 0)])
    699                                    (if (eq? key (##sys#slot pare 0))
    700                                        (let ([val (func (##sys#slot pare 1))])
    701                                          (##sys#setslot pare 1 val)
    702                                          val)
    703                                        (loop (##sys#slot bucket 1)) ) ) ] ) )
    704                         ; Slow path
    705                         (let loop ([bucket bucket0])
    706                           (cond [(null? bucket)
    707                                  (let ([val (func (thunk))])
    708                                    (##sys#setslot vec hshidx (cons (cons key val) bucket0))
    709                                    (##sys#setislot ht 2 newsiz)
    710                                    val) ]
    711                                 [else
    712                                  (let ([pare (##sys#slot bucket 0)])
    713                                    (if (test key (##sys#slot pare 0))
    714                                        (let ([val (func (##sys#slot pare 1))])
    715                                          (##sys#setslot pare 1 val)
    716                                          val)
    717                                        (loop (##sys#slot bucket 1)) ) ) ] ) ) ) ) ) ) ) ) ) ) ) )
    718 
    719 (define (hash-table-update!
    720          ht key
    721          #!optional (func identity)
    722                     (thunk
    723                      (let ([thunk (##sys#slot ht 9)])
    724                        (or thunk
    725                            (lambda ()
    726                              (##sys#signal-hook #:access-error
    727                               'hash-table-update!
    728                               "hash-table does not contain key" key ht))))))
    729   (##sys#check-structure ht 'hash-table 'hash-table-update!)
    730   (##sys#check-closure func 'hash-table-update!)
    731   (##sys#check-closure thunk 'hash-table-update!)
    732   (%hash-table-update! ht key func thunk) )
     688(define hash-table-update!
     689  (let ([core-eq? eq?] )
     690    (lambda (ht key
     691             #!optional (func identity)
     692                        (thunk
     693                         (let ([thunk (##sys#slot ht 9)])
     694                           (or thunk
     695                               (lambda ()
     696                                 (##sys#signal-hook #:access-error
     697                                  'hash-table-update!
     698                                  "hash-table does not contain key" key ht))))))
     699      (##sys#check-structure ht 'hash-table 'hash-table-update!)
     700      (##sys#check-closure func 'hash-table-update!)
     701      (##sys#check-closure thunk 'hash-table-update!)
     702      (let ([newsiz (fx+ (##sys#slot ht 2) 1)] )
     703        (%hash-table-check-resize! ht newsiz)
     704        (let ([hash (##sys#slot ht 4)]
     705              [test (##sys#slot ht 3)]
     706              [vec (##sys#slot ht 1)] )
     707          (let* ([len (##sys#size vec)]
     708                 [hshidx (hash key len)]
     709                 [bucket0 (##sys#slot vec hshidx)] )
     710            (if (eq? core-eq? test)
     711                ; Fast path (eq? is rewritten by the compiler):
     712                (let loop ([bucket bucket0])
     713                  (if (null? bucket)
     714                      (let ([val (func (thunk))])
     715                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
     716                        (##sys#setislot ht 2 newsiz)
     717                        val )
     718                      (let ([pare (##sys#slot bucket 0)])
     719                         (if (eq? key (##sys#slot pare 0))
     720                             (let ([val (func (##sys#slot pare 1))])
     721                               (##sys#setslot pare 1 val)
     722                               val)
     723                             (loop (##sys#slot bucket 1)) ) ) ) )
     724                ; Slow path
     725                (let loop ([bucket bucket0])
     726                  (if (null? bucket)
     727                      (let ([val (func (thunk))])
     728                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
     729                        (##sys#setislot ht 2 newsiz)
     730                        val )
     731                      (let ([pare (##sys#slot bucket 0)])
     732                         (if (test key (##sys#slot pare 0))
     733                             (let ([val (func (##sys#slot pare 1))])
     734                               (##sys#setslot pare 1 val)
     735                               val )
     736                             (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) ) )
     737
     738(define %hash-table-update!/default
     739  (let ([core-eq? eq?] )
     740    (lambda (ht key func def)
     741      (let ([newsiz (fx+ (##sys#slot ht 2) 1)] )
     742        (%hash-table-check-resize! ht newsiz)
     743        (let ([hash (##sys#slot ht 4)]
     744              [test (##sys#slot ht 3)]
     745              [vec (##sys#slot ht 1)] )
     746          (let* ([len (##sys#size vec)]
     747                 [hshidx (hash key len)]
     748                 [bucket0 (##sys#slot vec hshidx)] )
     749            (if (eq? core-eq? test)
     750                ; Fast path (eq? is rewritten by the compiler):
     751                (let loop ([bucket bucket0])
     752                  (if (null? bucket)
     753                      (let ([val (func def)])
     754                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
     755                        (##sys#setislot ht 2 newsiz)
     756                        val )
     757                      (let ([pare (##sys#slot bucket 0)])
     758                         (if (eq? key (##sys#slot pare 0))
     759                             (let ([val (func (##sys#slot pare 1))])
     760                               (##sys#setslot pare 1 val)
     761                               val)
     762                             (loop (##sys#slot bucket 1)) ) ) ) )
     763                ; Slow path
     764                (let loop ([bucket bucket0])
     765                  (if (null? bucket)
     766                      (let ([val (func def)])
     767                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
     768                        (##sys#setislot ht 2 newsiz)
     769                        val )
     770                      (let ([pare (##sys#slot bucket 0)])
     771                         (if (test key (##sys#slot pare 0))
     772                             (let ([val (func (##sys#slot pare 1))])
     773                               (##sys#setslot pare 1 val)
     774                               val )
     775                             (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) ) )
    733776
    734777(define (hash-table-update!/default ht key func def)
    735778  (##sys#check-structure ht 'hash-table 'hash-table-update!/default)
    736779  (##sys#check-closure func 'hash-table-update!/default)
    737   (%hash-table-update! ht key func (lambda () def)) )
    738 
    739 (define (hash-table-set! ht key val)
    740   (##sys#check-structure ht 'hash-table 'hash-table-set!)
    741   (let ([thunk (lambda _ val)])
    742     (%hash-table-update! ht key thunk thunk) )
    743   (void) )
     780  (%hash-table-update!/default ht key func def) )
     781
     782(define hash-table-set!
     783  (let ([core-eq? eq?] )
     784    (lambda (ht key val)
     785      (##sys#check-structure ht 'hash-table 'hash-table-set!)
     786      (let ([newsiz (fx+ (##sys#slot ht 2) 1)] )
     787        (%hash-table-check-resize! ht newsiz)
     788        (let ([hash (##sys#slot ht 4)]
     789              [test (##sys#slot ht 3)]
     790              [vec (##sys#slot ht 1)] )
     791          (let* ([len (##sys#size vec)]
     792                 [hshidx (hash key len)]
     793                 [bucket0 (##sys#slot vec hshidx)] )
     794            (if (eq? core-eq? test)
     795                ; Fast path (eq? is rewritten by the compiler):
     796                (let loop ([bucket bucket0])
     797                  (if (null? bucket)
     798                      (begin
     799                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
     800                        (##sys#setislot ht 2 newsiz) )
     801                      (let ([pare (##sys#slot bucket 0)])
     802                         (if (eq? key (##sys#slot pare 0))
     803                             (##sys#setslot pare 1 val)
     804                             (loop (##sys#slot bucket 1)) ) ) ) )
     805                ; Slow path
     806                (let loop ([bucket bucket0])
     807                  (if (null? bucket)
     808                      (begin
     809                        (##sys#setslot vec hshidx (cons (cons key val) bucket0))
     810                        (##sys#setislot ht 2 newsiz) )
     811                      (let ([pare (##sys#slot bucket 0)])
     812                         (if (test key (##sys#slot pare 0))
     813                             (##sys#setslot pare 1 val)
     814                             (loop (##sys#slot bucket 1)) ) ) ) ) )
     815            (void) ) ) ) ) ) )
    744816
    745817;; Hash-Table Reference:
    746818
    747 (define %hash-table-ref
     819(define hash-table-ref
     820  (getter-with-setter
     821    (let ([core-eq? eq?])
     822      (lambda (ht key #!optional (def (lambda ()
     823                                        (##sys#signal-hook #:access-error
     824                                         'hash-table-ref
     825                                         "hash-table does not contain key" key ht))))
     826        (##sys#check-structure ht 'hash-table 'hash-table-ref)
     827        (##sys#check-closure def 'hash-table-ref)
     828        (let  ([vec (##sys#slot ht 1)]
     829               [test (##sys#slot ht 3)] )
     830          (let* ([hash (##sys#slot ht 4)]
     831                 [hshidx (hash key (##sys#size vec))] )
     832            (if (eq? core-eq? test)
     833                ; Fast path (eq? is rewritten by the compiler):
     834                (let loop ([bucket (##sys#slot vec hshidx)])
     835                  (if (null? bucket)
     836                      (def)
     837                      (let ([pare (##sys#slot bucket 0)])
     838                        (if (eq? key (##sys#slot pare 0))
     839                            (##sys#slot pare 1)
     840                            (loop (##sys#slot bucket 1)) ) ) ) )
     841                ; Slow path
     842                (let loop ([bucket (##sys#slot vec hshidx)])
     843                  (if (null? bucket)
     844                      (def)
     845                      (let ([pare (##sys#slot bucket 0)])
     846                        (if (test key (##sys#slot pare 0))
     847                            (##sys#slot pare 1)
     848                            (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) )
     849   hash-table-set!) )
     850
     851(define hash-table-ref/default
    748852  (let ([core-eq? eq?])
    749853    (lambda (ht key def)
    750        (let  ([vec (##sys#slot ht 1)]
    751               [test (##sys#slot ht 3)] )
    752          (let* ([hash (##sys#slot ht 4)]
    753                 [hshidx (hash key (##sys#size vec))] )
     854      (##sys#check-structure ht 'hash-table 'hash-table-ref/default)
     855      (let  ([vec (##sys#slot ht 1)]
     856             [test (##sys#slot ht 3)] )
     857        (let* ([hash (##sys#slot ht 4)]
     858               [hshidx (hash key (##sys#size vec))] )
    754859           (if (eq? core-eq? test)
    755860               ; Fast path (eq? is rewritten by the compiler):
    756861               (let loop ([bucket (##sys#slot vec hshidx)])
    757862                 (if (null? bucket)
    758                      (def)
     863                     def
    759864                     (let ([pare (##sys#slot bucket 0)])
    760865                       (if (eq? key (##sys#slot pare 0))
    … …  
    764869               (let loop ([bucket (##sys#slot vec hshidx)])
    765870                 (if (null? bucket)
    766                      (def)
     871                     def
    767872                     (let ([pare (##sys#slot bucket 0)])
    768873                       (if (test key (##sys#slot pare 0))
    … …  
    770875                           (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) )
    771876
    772 (define hash-table-ref
    773   (getter-with-setter
    774    (lambda (ht key #!optional (def (lambda ()
    775                                      (##sys#signal-hook #:access-error
    776                                       'hash-table-ref
    777                                       "hash-table does not contain key" key ht))))
    778      (##sys#check-structure ht 'hash-table 'hash-table-ref)
    779      (##sys#check-closure def 'hash-table-ref)
    780      (%hash-table-ref ht key def) )
    781    hash-table-set!))
    782 
    783 (define (hash-table-ref/default ht key default)
    784   (##sys#check-structure ht 'hash-table 'hash-table-ref/default)
    785   (%hash-table-ref ht key (lambda () default)) )
    786 
    787 (define (hash-table-exists? ht key)
    788   (##sys#check-structure ht 'hash-table 'hash-table-exists?)
    789   (not ($unbound? (%hash-table-ref ht key unbound-value-thunk))) )
     877(define hash-table-exists?
     878  (let ([core-eq? eq?])
     879    (lambda (ht key)
     880      (##sys#check-structure ht 'hash-table 'hash-table-exists?)
     881      (let  ([vec (##sys#slot ht 1)]
     882             [test (##sys#slot ht 3)] )
     883        (let* ([hash (##sys#slot ht 4)]
     884               [hshidx (hash key (##sys#size vec))] )
     885          (if (eq? core-eq? test)
     886               ; Fast path (eq? is rewritten by the compiler):
     887               (let loop ([bucket (##sys#slot vec hshidx)])
     888                 (and (not (null? bucket))
     889                      (let ([pare (##sys#slot bucket 0)])
     890                        (or (eq? key (##sys#slot pare 0))
     891                            (loop (##sys#slot bucket 1)) ) ) ) )
     892               ; Slow path
     893               (let loop ([bucket (##sys#slot vec hshidx)])
     894                 (and (not (null? bucket))
     895                      (let ([pare (##sys#slot bucket 0)])
     896                        (or (test key (##sys#slot pare 0))
     897                            (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) )
    790898
    791899;; hash-table-delete!:
    … …  
    870978          [(null? lst)]
    871979        (let ([b (##sys#slot lst 0)])
    872           (%hash-table-update! ht1 (##sys#slot b 0)
    873                                    identity (lambda () (##sys#slot b 1))) ) ) ) ) )
     980          (%hash-table-update!/default ht1 (##sys#slot b 0) identity (##sys#slot b 1)) ) ) ) ) )
    874981
    875982(define (hash-table-merge! ht1 ht2)
    … …  
    9061013      (let ([ht (apply make-hash-table rest)])
    9071014        (for-each (lambda (x)
    908                     (%hash-table-update! ht (##sys#slot x 0)
    909                                             identity (lambda () (##sys#slot x 1))) )
     1015                    (%hash-table-update!/default  ht (##sys#slot x 0) identity (##sys#slot x 1)) )
    9101016                  alist)
    9111017        ht ) ) ) )
Note: See TracChangeset for help on using the changeset viewer.