😇

SchemeのEphemeronで(少し良い)弱 hash tableを作る

2020/10/03に公開

3件

Schemeの標準仕様の大きい方であるR7RS large (red)内にEphemeronというものが入っている。
弱連想リストや弱hash tableの部品に使うことを意識したデータ構造で、これで弱hash tableを作ってみようという内容。
単純に弱hash tableを実装すると、key-datum対のkeyがdatumからの強参照だけが残っている状態の場合、key-datum対が回収されないということが起きる。(他はだれもkeyのオブジェクトをもっていなくて、keyを使って参照されることがないためそのようなkey-datum対は不要なので破棄したい)
Ephemeronを使って弱hash-tableを作るとそういった問題は回避できる。
タイトルの"(少し良い)"というのはこの問題回避できるという部分のこと。

Ephemeronについて

Ephemeronは、単純なweak-pair (car部が弱参照でcdr部が強参照なpair) を改良して、弱いkey-datum対としてより良いものになっている。
Ephemeronオブジェクトは、次のような挙動になっている。
以下 carをkey、cdrをdatumと呼ぶ。

keyは弱参照で datumは処理系次第の強さの参照
keyが回収可能ならば、ephemeronオブジェクトはbokenになり、key,datumの参照ができなくなる
keyがdatumからのみ強参照できる場合もEphemeronオブジェクトはbrokenにできる

特にこの3つめの部分がEphemeronの特徴的な部分で、「keyがdatumからのみ強参照されるということは、そのEphemeronオブジェクトのkeyはだれも参照しないわけで、もはや不要だ」ということを反映している。
この機能は実装もトレース系GCに手を加えることができればそれほど難しくはないが、それをしないと実装できないような機能になっていて、弱参照とファイナライズを使った3つめが不完全な、なんちゃってEphemeron実装は割とある。

これは、青を弱参照、緑をEphemeron datum参照とした場合の図。

Ephemeronで弱hash table

構造的には、key-datumを保持しているペアをEphemeronに変えたという点以外は普通のチェイン法のhash tableと変わらない。
特徴は、keyがだれも参照できないことが保証できるならば(強参照が、datumからのみであるか、全くない状態)、keyとkey-value対(つまりEphemeronオブジェクト)が回収されるということ。
図で書くとこうなる。赤は強参照、青は弱参照、緑はEphemeron datum参照。

見ての通り、vectorで表現されたハッシュテーブルのバケットに連結リストをいれて、その各要素にkey-datumを入れたEphemeronをもたせている。

brokenなEphemeronの扱い

keyをdatum以外が強参照していない時、Ephemeronは自動でbroken状態になるが、そのbrokenなEphemeronを消すための処理は実装する必要がある。要素の参照や登録時にbrokenなEphemeronを見つけた場合、連結リストからそれを削除すればよい。実装では、brokenなEphemeronを持っている連結リストの手前のペアと次のペアをつなげている。brokenなEphemeronは誰からも参照されなくなるので、次のGCで回収される。

SchemeでのEphemeronを使った　弱hashテーブルの実装

hash手続きはすでにあるものを使う。R7RS largeでは、(scheme comparator)ライブラリがあるので、その中のeq-comparatorとcomparator-hashを使う。
ただ、処理系によっては、(scheme comparator)のeq-comparatorが想定の操作と違ったものがあったりするので、適宜 with-drawnになったcomparatorである(srfi 114)を使う。
cond-expandを使ってこの辺の場合分けをする。

   (cond-expand
     (gauche
      (import (scheme base)
              (scheme ephemeron)
              ;Comparator(withdrawn)
              (only (srfi 114) eq-comparator comparator-hash))
      (begin (define %comparator eq-comparator)))
     (else
       (import (scheme base)
               (srfi 128)
               (srfi 124))
       (begin (define %comparator (make-eq-comparator)))))

作成した手続き(補助手続きは除く)は次の通り。
R7RS largeの(scheme hash-table)と比べると、機能が足りないが、足りない部分はこれらを元に作成できる(はず)。

   (export make-ephemeron-hash-table ephemeron-hash-table-ref
          ephemeron-hash-table? ephemeron-hash-table-set!
          ephemeron-hash-table-delete!)

弱ハッシュテーブルを構造体 (record) として、定義しておく。
名前は、ephemeron-hash-tableとした。
弱ハッシュテーブルかどうかを判定する、述語であるephemeron-hash-table?以外のアクセサやコンストラクタは内部から呼ばれる手続き扱い。

      (define-record-type <ephemeron-hash-table>
         (%make-ephemeron-hash-table table-data)
         ephemeron-hash-table?
         (table-data %table-data-ref %table-data-set!))

keyをもつephemeronを探す補助手続き。
brokenなephemeronを見つけると、それを持つペアを連結リストから外す。
brokenなephemeronの判定部分と同時に、連結リスト内の要素がnullかどうかの判定を行っているが、これは、ephemeron-hash-table-delete!内でdeleteしたいkeyを持つephemeronをnullに置き換える操作をしているため。(ephemeron-hash-table-delete!内で連結リストの前のペアと次のペアを繋げる操作が面倒だったためこうなっている)

Ephemeronのkeyをekeyという名でletの中身を束縛しているのは、cond内の(ephemeron-broken? (car ealist))後にGCが走り、ephemeronがbroken状態になることを防ぐためにしている。

      (define (%ephem-alist-ref-and-trim ealist key)
        (let loop ((ealist ealist)
                   (prev '()))
          (if (null? ealist)
            #f
            (let ((ekey (or (null? (car ealist))
                                 (ephemeron-key (car ealist)))))
             (cond
               ((or (null? (car ealist))
                     (ephemeron-broken? (car ealist)))
                (unless (null? prev) (set-cdr! prev (cdr ealist)))
                (loop (cdr ealist) prev))
               ((eq? ekey key) ealist)
               (else (loop (cdr ealist) ealist)))))))

このkey-datum対を探す"%ephem-alist-ref-and-trim"手続きを使い、普通のチェイン法を使ったhash-tableと同じように実装すればEphemeronを使った弱hash-tableが作れる。
残りは末尾のコードを参照。

Ephemeronの注意点

最初にこの記事を公開していた時に提示したソースコードはミスがあった。(下のshiroさんのコメントを参照)
簡略化した次のコードを使って説明する。
このコードは、Ephemeronがbrokenならば、something1を返却し、ephemのkeyがarg-keyとeq?で等しければsomething2を返すということを行う。
また、前提として、このephemのkeyはだれも参照しておらず、次のGCでephemはbrokenになるとする。

(lambda (arg-key)
    (cond
       ((ephemeron-broken? ephem) something1)
       ((eq? (ephemeron-key ephem) arg-key) something2))

問題は、ephemeron-broken?の後にGCが起きて、ephemがbroken状態になり、ephemがbrokenでないということでコードが進行してしまう点にある。
ephemがbrokenの時、(ephemeron-key ephem)の結果は、#fになるので、arg-keyが#fだった場合、意図せず、something2が起きてしまう。
対処方としては、次のように、ephemeron-keyの強参照をもっておいて、関数を抜けるまでは壊れかけの(次のGCでbrokenするような、datum以外から強参照のないこと)Ephemeronがbrokenしないようにする。

(lambda (arg-key)
　 (let ((ekey (ephemeron-key ephem)))
      (cond
         ((ephemeron-broken? ephem) something1)
         ((eq?  ekey arg-key) something2))

こうすれば、

ephemがephemeron-broken?前で壊れているならば、そもそもephemeron-broken?が#tになるので期待どおり動く。
ephemがephemeron-broken?の呼び出しから、強参照をもったletを抜けるまではbrokenにならないことが保証できる。
ので、意図しない動作を生じなくさせることができる。

その他

EphemeronとWeak pairについてはこの辺を参照すると良いと思う。

コード全体

このソースコードは(パブリックドメイン)
インデントが崩れているので、Gistsにも貼った。

(define-library (ephemeron-hash-table)
   (cond-expand
     (gauche
      (import (scheme base)
              (scheme ephemeron)
              ;Comparator(withdrawn)
              (only (srfi 114) eq-comparator comparator-hash))
      (begin (define %comparator eq-comparator)))
     (else
       (import (scheme base)
               (srfi 128)
               (srfi 124))
       (begin (define %comparator (make-eq-comparator)))))

   (export make-ephemeron-hash-table ephemeron-hash-table-ref
           ephemeron-hash-table? ephemeron-hash-table-set!
           ephemeron-hash-table-delete!)
   (begin
      (define-record-type <ephemeron-hash-table>
         (%make-ephemeron-hash-table table-data)
         ephemeron-hash-table?
         (table-data %table-data-ref %table-data-set!))

      (define *DEFAULT-TABLE-SIZE* 128)

      (define (make-ephemeron-hash-table . opt)
        (let ((size (cond ((null? opt) *DEFAULT-TABLE-SIZE*)
                          ((integer? (car opt)) (car opt))
                          (else (error "make-ephemeron-hash-table only accepts
                                       1 or 0 integer arguments.")))))
          (%make-ephemeron-hash-table (make-vector size '()))))

      (define (%ephem-alist-ref-and-trim ealist key)
        (let loop ((ealist ealist)
                   (prev '()))
          (if (null? ealist)
            #f
            (let ((ekey (or (null? (car ealist))
                            (ephemeron-key (car ealist)))))
             (cond
               ((or (null? (car ealist))
                    (ephemeron-broken? (car ealist)))
                (unless (null? prev) (set-cdr! prev (cdr ealist)))
                (loop (cdr ealist) prev))
               ((eq? ekey key) ealist)
               (else (loop (cdr ealist) ealist)))))))

      (define (ephemeron-hash-table-set! ephemeron-hash-table key val)
        (unless (ephemeron-hash-table? ephemeron-hash-table)
            (error "The first argument of ephemeron-hash-table-set!
                   must be ephemeron hash-table"))
        (let* ((table-data (%table-data-ref ephemeron-hash-table))
               (hash-value (comparator-hash %comparator key))
               (mod-hash (modulo hash-value (vector-length table-data)))
               (ephem-alist (vector-ref table-data mod-hash))
               (tgt-ephemeron-apair-box
                 (%ephem-alist-ref-and-trim ephem-alist key)))
         (if tgt-ephemeron-apair-box
            (set-car! tgt-ephemeron-apair-box (make-ehemeron key val))
            (vector-set! table-data
                         mod-hash
                         (cons (make-ephemeron key val) ephem-alist)))))

      (define (ephemeron-hash-table-ref ephemeron-hash-table key)
        (unless (ephemeron-hash-table? ephemeron-hash-table)
            (error "The argument of ephemeron-hash-table-ref
                   must be ephemeron hash-table"))
        (let* ((table-data (%table-data-ref ephemeron-hash-table))
               (mod-hash (modulo (comparator-hash %comparator key)
                                 (vector-length table-data)))
               (tgt-ephemeron-apair-box
                 (%ephem-alist-ref-and-trim (vector-ref table-data mod-hash)
                                            key)))
            (if tgt-ephemeron-apair-box
              (ephemeron-datum (car tgt-ephemeron-apair-box))
              #f)))

      (define (%ephem-ht->al-aux ephem-alist cdr-part)
         (let loop ((ls ephem-alist~)
                    (res cdr-part))
           (cond
             ((null? ls) res)
             ((or (null? (car ls)) (ephemeron-broken? (car ls)))
              (loop (cdr ls) res))
             (else
               (loop (cdr ls)
                     (cons (cons (ephemeron-key (car ls))
                                 (ephemeron-datum (car ls)))
                           res))))))

      (define (ephemeron-hash-table->alist ephemeron-hash-table)
        (unless (ephemeron-hash-table? ephemeron-hash-table)
            (error "The argument of ephemeron-hash-table->alist
                   must be epehemron hash-table"))
        (let ((table-data (%table-data-ref ephemeron-hash-table)))
           (let loop ((idx 0)
                      (res '()))
             (if (< idx (vector-length table-data))
               (loop (+ idx 1)
                     (%ephem-ht->al-aux (vector-ref table-data idx) res))
               res))))

      (define (ephemeron-hash-table-delete! ephemeron-hash-table key)
        (unless (ephemeron-hash-table? ephemeron-hash-table)
            (error "The argument of ephemeron-hash-table->alist
                   must be epehemron hash-table"))
        (let* ((table-data (%table-data-ref ephemeron-hash-table))
               (mod-hash (modulo (comparator-hash %comparator key)
                                 (vector-length table-data)))
               (tgt-ephemeron-apair-box
                 (%ephem-alist-ref-and-trim (vector-ref table-data mod-hash)
                                            key)))
            (when tgt-ephemeron-apair-box
              (set-car! tgt-ephemeron-apair-box '()))))))