From 2c02a21023c946a3d31c43417d440d6babbf2622 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 29 Jun 2014 14:29:20 +0200 Subject: [PATCH] Remove namesets. This was a failed experiment. It had good space complexity but terrible time complexity. * module/Makefile.am: Update. * module/language/cps/nameset.scm: Remove. --- module/Makefile.am | 1 - module/language/cps/nameset.scm | 396 -------------------------------- 2 files changed, 397 deletions(-) delete mode 100644 module/language/cps/nameset.scm diff --git a/module/Makefile.am b/module/Makefile.am index 59fd1d2ba..aa7f8ee0b 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -133,7 +133,6 @@ CPS_LANG_SOURCES = \ language/cps/elide-values.scm \ language/cps/intmap.scm \ language/cps/intset.scm \ - language/cps/nameset.scm \ language/cps/primitives.scm \ language/cps/prune-bailouts.scm \ language/cps/prune-top-level-scopes.scm \ diff --git a/module/language/cps/nameset.scm b/module/language/cps/nameset.scm deleted file mode 100644 index 823da6155..000000000 --- a/module/language/cps/nameset.scm +++ /dev/null @@ -1,396 +0,0 @@ -;;; Functional name maps -;;; Copyright (C) 2014 Free Software Foundation, Inc. -;;; -;;; This library is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This library is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this program. If not, see -;;; . - -;;; Commentary: -;;; -;;; Some CPS passes need to perform a flow analysis in which every -;;; program point has an associated map over some set of labels or -;;; variables. The naive way to implement this is with an array of -;;; arrays, but this has N^2 complexity, and it really can hurt us. -;;; -;;; Instead, this module provides a functional map that can share space -;;; between program points, reducing the amortized space complexity of -;;; the representations down to O(n). Adding entries to the mapping is -;;; O(1), though lookup is O(log n). When augmented with a dominator -;;; analysis, "meet" operations (intersection or union) can be made in -;;; O(log n) time as well, which results in overall O(n log n) -;;; complexity for flow analysis. (It would be nice to prove this -;;; properly; I could have some of the details wrong.) -;;; -;;; Namesets are functional hashed lists that map names (unsigned -;;; integers) to values. Instead of using vhashes from ice-9/vlist.scm, -;;; we copy that code below and specialize it to hold pointerless tuple -;;; values. The code was originally written by Ludovic Courtès -;;; . See ice-9/vlist.scm for more detailed commentary. -;;; -;;; A nameset backing store starts with the entries of the hash table, -;;; including the chain links, the keys, and the payload. A bucket list -;;; array follows. -;;; -;;; Although the hash table logic is the same for all namesets, each -;;; nameset kind can have its own payload size and format. Adding an -;;; entry to a nameset fills in the next unused hash entry slot and -;;; updates the corresponding bucket to point to the newly allocated -;;; hash entry. -;;; -;;; As an example, consider a nameset with two entries, each with its -;;; key K, and with 12 bytes of payload consisting of type T and range -;;; R- and R+. Assume that H = hashv(K1) = hashv(K2). The resulting -;;; layout is as follows: -;;; -;;; byte offset contents -;;; 0 ,---------------------------. -;;; +4 | size | Header -;;; +8 | next-free | -;;; 8 +---------------------------+ -;;; +0 | -1, K1, T1, R-1, R+1 | -;;; +20 | ,-> 0, K2, T2, R-2, R+2 | Chain links -;;; +40 | | | -;;; 8 + size * 20 +-|-------------------------+ -;;; +0 | | -1 | Hash buckets -;;; +4 | | -1 | -;;; +8 | '-- 1 <-------------------- H -;;; 8 + size * 24 `---------------------------' -;;; -;;; For the purposes of illustration, the backing store has size 3, -;;; indicating space for three entries. In practice backing stores will -;;; only have power-of-two sizes. -;;; -;;; Code: - -(define-module (language cps nameset) - #:use-module (rnrs bytevectors) - #:export (define-nameset-type)) - -(define-syntax define-nameset-type - (lambda (x) - (define (id base suffix) - (datum->syntax base (symbol-append (syntax->datum base) suffix))) - (define-syntax-rule (with-ids (stem suffix ...) body) - (with-syntax ((suffix (id stem 'suffix)) - ...) - body)) - (syntax-case x () - ((_ (stem val ... #:size size) read write meet) - (with-ids - (#'stem -null -lookup -ref -has-entry? -length -add -meet) - #'(define-values (-null -lookup -ref -has-entry? -length -add -meet) - (let ((read* read) (write* write) (meet* meet)) - (nameset-type (val ... #:size size) - read* write* meet*)))))))) - -(define-syntax-rule (nameset-type (val ... #:size *value-size*) - value-ref value-set! - value-meet) - (let* ((*size-offset* 0) - (*next-free-offset* 4) - (*header-size* 8) - - ;; int32 link - (*link-size* 4) - (*link-offset* 0) - ;; uint32 key - (*key-size* 4) - (*key-offset* 4) - - ;; *value-size* is a parameter. - (*value-offset* 8) - - (*entry-size* (+ *key-size* *link-size* *value-size*)) - - ;; int32 bucket - (*bucket-size* 4)) - - (define (block-size block) - (bytevector-u32-native-ref block *size-offset*)) - (define (block-next-free block) - (bytevector-u32-native-ref block *next-free-offset*)) - - (define (set-block-next-free! block next-free) - (bytevector-u32-native-set! block *next-free-offset* next-free)) - - (define (block-key-ref block offset) - (let ((entry (+ *header-size* (* offset *entry-size*)))) - (bytevector-u32-native-ref block (+ entry *key-offset*)))) - - (define (block-link-ref block offset) - (let ((entry (+ *header-size* (* offset *entry-size*)))) - (bytevector-s32-native-ref block (+ entry *link-offset*)))) - - (define (block-value-ref block offset) - (let ((entry (+ *header-size* (* offset *entry-size*)))) - (value-ref block (+ entry *value-offset*)))) - - (define (hash-bucket-offset size khash) - (+ *header-size* (* size *entry-size*) (* khash *bucket-size*))) - - ;; Returns the index of the last entry stored in BLOCK with - ;; SIZE-modulo hash value KHASH. - (define (block-hash-bucket-ref block size khash) - (bytevector-s32-native-ref block (hash-bucket-offset size khash))) - - (define (block-entry-init! block offset key val ...) - (let* ((size (block-size block)) - (entry (+ *header-size* (* offset *entry-size*))) - (hash (hashv key size)) - (link (block-hash-bucket-ref block size hash))) - (bytevector-s32-native-set! block (+ entry *link-offset*) link) - (bytevector-u32-native-set! block (+ entry *key-offset*) key) - (value-set! block (+ entry *value-offset*) val ...) - (bytevector-s32-native-set! block (hash-bucket-offset size hash) offset))) - - (define (make-block size) - ;; Having the fill value be -1 makes the initial buckets empty. The - ;; fill value doesn't affect the other fields. - (let ((bv (make-bytevector (+ *header-size* - (* size (+ *entry-size* *bucket-size*))) - -1))) - (bytevector-u32-native-set! bv *size-offset* size) - (bytevector-u32-native-set! bv *next-free-offset* 0) - bv)) - - ;;; - ;;; nameset := (OFFSET . HEAD) - ;;; head := (BLOCK . TAIL) - ;;; tail := '() | NAMESET - ;;; - (define (make-nameset offset head) (cons offset head)) - (define (nameset-offset nameset) (car nameset)) - (define (nameset-head nameset) (cdr nameset)) - - (define (make-nameset-head block tail) (cons block tail)) - (define (nameset-head-block head) (car head)) - (define (nameset-head-tail head) (cdr head)) - - (define (nameset-block nameset) - (nameset-head-block (nameset-head nameset))) - (define (nameset-tail nameset) - (nameset-head-tail (nameset-head nameset))) - - (define block-null (make-block 0)) - (define nameset-null (make-nameset 0 (make-nameset-head block-null '()))) - - (define (nameset-ref nameset index) - "Return the element at index INDEX in NAMESET." - (let loop ((index index) - (nameset nameset)) - (let ((block (nameset-block nameset)) - (offset (nameset-offset nameset))) - (if (<= index offset) - (call-with-values (lambda () - (block-value-ref block (- offset index))) - (lambda (val ...) - (values (block-key-ref block (- offset index)) val ...))) - (loop (- index offset 1) (nameset-tail nameset)))))) - - (define* (nameset-lookup nameset name #:optional max-depth) - "Return the index at which NAME is found, or #f if NAME is not present -in NAMESET." - (let lookup ((nameset nameset) (pos 0)) - (let* ((max-offset (nameset-offset nameset)) - (block (nameset-block nameset)) - (size (block-size block))) - (and (> size 0) - (let visit-link ((offset (block-hash-bucket-ref block size - (hashv name size)))) - (cond - ((and max-depth (>= (+ pos (- max-offset offset)) max-depth)) - #f) - ((< offset 0) - (lookup (nameset-tail nameset) (+ pos (1+ max-offset)))) - ((and (<= offset max-offset) - (eqv? name (block-key-ref block offset))) - (+ pos (- max-offset offset))) - (else - (visit-link (block-link-ref block offset))))))))) - - (define-syntax-rule (tmp-id prefix id) - (datum->syntax prefix - (symbol-append (syntax->datum prefix) - '- - (syntax->datum id)))) - - (define-syntax &t - (lambda (x) - (syntax-case x () - ((_ stem id) (tmp-id #'stem #'id))))) - - (define-syntax lambda&t - (lambda (x) - (syntax-case x () - ((_ stem (id (... ...)) body (... ...)) - (with-syntax (((t (... ...)) - (map (lambda (x) (tmp-id #'stem x)) - #'(id (... ...))))) - #'(lambda (t (... ...)) body (... ...))))))) - - (define (nameset-has-entry? nameset name val ...) - (cond - ((nameset-lookup nameset name) - => (lambda (idx) - (call-with-values (lambda () (nameset-ref nameset idx)) - (lambda&t - existing (name val ...) - (and (eqv? val (&t existing val)) - ...))))) - (else #f))) - - (define (nameset-length nameset) - "Return the length of NAMESET." - (let loop ((nameset nameset) - (len 0)) - (if (eq? nameset nameset-null) - len - (loop (nameset-tail nameset) - (+ len 1 (nameset-offset nameset)))))) - - (define (nameset-add nameset name val ...) - "Return a new nameset, with the additional association of NAME -with VAL..." - (define (next-nameset nameset) - (let* ((block (nameset-block nameset)) - (offset (1+ (nameset-offset nameset))) - (old-size (block-size block))) - (cond - ((and (< offset old-size) - (= offset (block-next-free block))) - ;; Fast path: Add the item directly to the block. - (set-block-next-free! block (1+ offset)) - (values (make-nameset offset (nameset-head nameset)) - block - offset)) - (else - ;; Slow path: Allocate a new block. - (let* ((new-size (cond ((zero? old-size) 1) - ((< offset old-size) 1) ;; new head - (else (* 2 old-size)))) - (block (make-block new-size))) - (set-block-next-free! block 1) - (values (make-nameset 0 (make-nameset-head block nameset)) - block - 0)))))) - - (call-with-values (lambda () (next-nameset nameset)) - (lambda (nameset block offset) - (block-entry-init! block offset name val ...) - nameset))) - - (define (nameset-adjoin nameset name val ...) - "Like nameset-add, but doesn't add a new association if one exists -already." - (if (nameset-has-entry? nameset name val ...) - nameset - (nameset-add nameset name val ...))) - - (define (nameset-shared-tail a b) - (let lp ((a-offset (nameset-offset a)) - (a-head (nameset-head a)) - (a-len (nameset-length a)) - (b-offset (nameset-offset b)) - (b-head (nameset-head b)) - (b-len (nameset-length b))) - (cond - ((< b-len a-len) - ;; Ensure A is the shorter list. - (lp b-offset b-head b-len - a-offset a-head a-len)) - ((< a-len b-len) - ;; Traverse B until it is not the longer list. - (if (< (- b-len a-len) (1+ b-offset)) - (lp a-offset a-head a-len - (- b-offset (- b-len a-len)) b-head a-len) - (let ((b (nameset-head-tail b-head))) - (lp a-offset a-head a-len - (nameset-offset b) - (nameset-head b) - (- b-len (1+ b-offset)))))) - ((< b-offset a-offset) - ;; Ensure A is the list with the least block offset. - (lp b-offset b-head b-len - a-offset a-head a-len)) - ((not (eq? (nameset-head-block a-head) (nameset-head-block b-head))) - ;; Lists are of equal length but don't have the same block -- - ;; their offsets must differ, and A must have the smaller offset. - (let ((a (nameset-head-tail a-head))) - (lp (nameset-offset a) - (nameset-head a) - (- a-len (1+ a-offset)) - (- b-offset (1+ a-offset)) - b-head - (- b-len (1+ a-offset))))) - (else - ;; Lists are of equal length and have the same block, and thus - ;; must have the same offset -- they are the same. We found - ;; the shared tail. Try to preserve eq? identity if possible. - (cond - ((and (eqv? (nameset-offset a) a-offset) - (eq? (nameset-head a) a-head)) - a) - ((and (eqv? (nameset-offset b) a-offset) - (eq? (nameset-head b) a-head)) - b) - (else - (make-nameset a-offset a-head))))))) - - (define* (nameset-meet base new old adjoin) - (let* ((len (nameset-length base)) - (new-len (- (nameset-length new) - (nameset-length (nameset-shared-tail new old))))) - (let lp ((offset (nameset-offset new)) - (block (nameset-block new)) - (tail (nameset-tail new)) - (visited 0) - (base base) - (added 0)) - (cond - ((= visited new-len) - ;; Done with adjoining new entries. - base) - ((< offset 0) - ;; Reached the end of the current block; keep going with - ;; the next one. - (lp (nameset-offset tail) - (nameset-block tail) - (nameset-tail tail) - visited - base - added)) - (else - (let ((name (block-key-ref block offset))) - (define (recur base*) - (lp (1- offset) block tail (1+ visited) - base* (if (eq? base base*) added (1+ added)))) - - (cond - ((nameset-lookup new name visited) - ;; This name is shadowed by a more shallow entry. - (recur base)) - ;; Otherwise meet the entry in A with the entry in B. - (else - (call-with-values - (lambda () - (block-value-ref block offset)) - (lambda (val ...) - (recur (adjoin base name val ...)))))))))))) - - (values nameset-null - nameset-lookup - nameset-ref - nameset-has-entry? - nameset-length - nameset-add - nameset-meet))) -- 2.20.1