Optimize mmap and odb: native 64-bit loads, cached slot layout
ober
f337b6adab50fdcaea5cb709ee216243b8ed74c2
--- a/lib/std/odb.sls +++ b/lib/std/odb.sls @@ -123,7 +123,8 @@ (mutable count) ;; Number of live objects (mutable capacity) ;; Max objects before grow (mutable file-path) ;; Backing file path - (mutable clos-class))) ;; The CLOS class object + (mutable clos-class) ;; The CLOS class object + (mutable slot-layout))) ;; Hashtable: slot-name -> (offset . type) [fast path] ;; ========================================================================= ;; Tagged pointer (mptr) @@ -234,6 +235,8 @@ (%c-close (%odb-lock-fd store)) (%odb-lock-fd-set! store #f)) (%odb-open?-set! store #f) + ;; Clear tag->info cache (stale after close) + (hashtable-clear! *tag->info*) (when (eq? (*odb*) store) (*odb* #f)))) (define (odb-sync . opts) @@ -295,7 +298,8 @@ (quotient (- (mmap-region-size region) *header-size*) rec-sz) - file-path #f)]) + file-path #f + (make-eq-hashtable))]) (hashtable-set! (%odb-classes store) name info) (when (> tag (%odb-next-tag store)) (%odb-next-tag-set! store (+ tag 1))) @@ -346,6 +350,17 @@ (string->symbol (substring s 1 (string-length s))) t))) + ;; Build combined slot-name -> (offset . type) hashtable for O(1) lookup + (define (build-slot-layout slot-names slot-types slot-offsets) + (let ([ht (make-eq-hashtable)]) + (for-each + (lambda (name type) + (let ([off (hashtable-ref slot-offsets name #f)]) + (when off + (hashtable-set! ht name (cons off type))))) + slot-names slot-types) + ht)) + (define (register-persistent-class! name slot-specs clos-class) (let ([store (*odb*)]) (unless store (error 'register-persistent-class! "no open store")) @@ -361,6 +376,8 @@ (persistent-class-info-slot-types-set! existing slot-types) (persistent-class-info-slot-offsets-set! existing slot-offsets) (persistent-class-info-record-size-set! existing record-size) + (persistent-class-info-slot-layout-set! + existing (build-slot-layout slot-names slot-types slot-offsets)) existing) ;; Create new (let* ([tag (%odb-next-tag store)] @@ -373,7 +390,8 @@ tag name slot-names slot-types slot-offsets record-size #f 0 *initial-capacity* file-path - clos-class)]) + clos-class + (build-slot-layout slot-names slot-types slot-offsets))]) ;; Create backing file (create-backing-file! file-path file-size) ;; Memory-map it @@ -478,18 +496,20 @@ ;; A persistent object in Scheme is a lightweight proxy: (tag . offset). ;; It references data in the mmap region, not heap memory. - ;; Persistent objects are CLOS instances with hidden %odb-tag, %odb-offset, %odb-store slots. - ;; These accessors extract the proxy info from any persistent CLOS object. + ;; Persistent objects are CLOS instances with hidden slots: + ;; %odb-tag, %odb-offset, %odb-store, %odb-info + ;; Storing %odb-info directly avoids the tag->info scan on every access. (define (odb-proxy? obj) (and (instance? obj) - (slot-exists? obj '%odb-tag) - (slot-bound? obj '%odb-tag) - (not (not (slot-ref obj '%odb-tag))))) + (slot-exists? obj '%odb-info) + (slot-bound? obj '%odb-info) + (not (not (slot-ref obj '%odb-info))))) (define (odb-proxy-tag obj) (slot-ref obj '%odb-tag)) (define (odb-proxy-offset obj) (slot-ref obj '%odb-offset)) (define (odb-proxy-store obj) (slot-ref obj '%odb-store)) + (define (odb-proxy-info obj) (slot-ref obj '%odb-info)) ;; Create a CLOS persistent object wrapper from raw mmap data (define (make-persistent-proxy tag offset store) @@ -500,9 +520,9 @@ (slot-set! obj '%odb-tag tag) (slot-set! obj '%odb-offset offset) (slot-set! obj '%odb-store store) + (slot-set! obj '%odb-info info) obj) ;; Fallback: class not yet defined (pre-registration scan) - ;; Use a simple vector as placeholder (vector 'odb-proxy tag offset store)))) (define (proxy->info proxy) @@ -534,18 +554,17 @@ ;; ========================================================================= (define (odb-slot-ref proxy slot-name) - (let* ([info (proxy->info proxy)] - [region (persistent-class-info-region info)] - [offset (odb-proxy-offset proxy)] - [slot-off (hashtable-ref (persistent-class-info-slot-offsets info) - slot-name #f)] - [slot-idx (list-index slot-name (persistent-class-info-slot-names info))] - [type (and slot-idx (list-ref (persistent-class-info-slot-types info) - slot-idx))]) - (unless slot-off + (let* ([info (odb-proxy-info proxy)] + [layout-entry (hashtable-ref (persistent-class-info-slot-layout info) + slot-name #f)]) + (unless layout-entry (error 'odb-slot-ref "no such slot" slot-name (persistent-class-info-name info))) - (let ([raw (odb-slot-ref-raw region offset slot-off type)]) + (let* ([slot-off (car layout-entry)] + [type (cdr layout-entry)] + [region (persistent-class-info-region info)] + [offset (odb-proxy-offset proxy)] + [raw (odb-slot-ref-raw region offset slot-off type)]) ;; For mptr types, return a proxy (if (and (eq? type 'mptr) (> raw 0)) (make-persistent-proxy (mptr-tag raw) (mptr-offset raw) @@ -553,24 +572,22 @@ raw)))) (define (odb-slot-set! proxy slot-name value) - (let* ([info (proxy->info proxy)] - [region (persistent-class-info-region info)] - [offset (odb-proxy-offset proxy)] - [slot-off (hashtable-ref (persistent-class-info-slot-offsets info) - slot-name #f)] - [slot-idx (list-index slot-name (persistent-class-info-slot-names info))] - [type (and slot-idx (list-ref (persistent-class-info-slot-types info) - slot-idx))]) - (unless slot-off + (let* ([info (odb-proxy-info proxy)] + [layout-entry (hashtable-ref (persistent-class-info-slot-layout info) + slot-name #f)]) + (unless layout-entry (error 'odb-slot-set! "no such slot" slot-name (persistent-class-info-name info))) - ;; Convert proxy values to mptrs - (let ([raw (if (and (eq? type 'mptr) (odb-proxy? value)) - (make-mptr (odb-proxy-tag value) (odb-proxy-offset value)) - value)]) + (let* ([slot-off (car layout-entry)] + [type (cdr layout-entry)] + [region (persistent-class-info-region info)] + [offset (odb-proxy-offset proxy)] + ;; Convert proxy values to mptrs + [raw (if (and (eq? type 'mptr) (odb-proxy? value)) + (make-mptr (odb-proxy-tag value) (odb-proxy-offset value)) + value)]) (odb-slot-set!-raw region offset slot-off type raw) - (let ([store (odb-proxy-store proxy)]) - (%odb-dirty?-set! store #t))))) + (%odb-dirty?-set! (odb-proxy-store proxy) #t)))) (define (list-index item lst) (let loop ([l lst] [i 0]) @@ -602,6 +619,7 @@ (slot-set! obj '%odb-tag (persistent-class-info-tag info)) (slot-set! obj '%odb-offset offset) (slot-set! obj '%odb-store store) + (slot-set! obj '%odb-info info) ;; Apply initargs to persistent slots (let loop ([args initargs]) (when (and (pair? args) (pair? (cdr args))) @@ -886,7 +904,8 @@ (datum->syntax #'class-name n)) '((%odb-tag :initform #f) (%odb-offset :initform #f) - (%odb-store :initform #f))) + (%odb-store :initform #f) + (%odb-info :initform #f))) ;; User-defined slots with virtual allocation (map (lambda (sd) (let ([name (car sd)] --- a/lib/std/os/mmap.sls +++ b/lib/std/os/mmap.sls @@ -244,65 +244,95 @@ (let ([u (mmap-u16-ref region offset endianness)]) (if (>= u #x8000) (- u #x10000) u))) + ;; Native endianness detection (for fast-path direct loads) + (define *native-endian* + (if (eq? (native-endianness) (endianness little)) 'little 'big)) + (define (mmap-u32-ref region offset endianness) (mmap-check-bounds region offset 4 'mmap-u32-ref) - (let* ([addr (+ (mmap-region-addr region) offset)] - [b0 (foreign-ref 'unsigned-8 addr 0)] - [b1 (foreign-ref 'unsigned-8 addr 1)] - [b2 (foreign-ref 'unsigned-8 addr 2)] - [b3 (foreign-ref 'unsigned-8 addr 3)]) - (case endianness - [(little) - (bitwise-ior b0 - (bitwise-arithmetic-shift b1 8) - (bitwise-arithmetic-shift b2 16) - (bitwise-arithmetic-shift b3 24))] - [(big) - (bitwise-ior (bitwise-arithmetic-shift b0 24) - (bitwise-arithmetic-shift b1 16) - (bitwise-arithmetic-shift b2 8) - b3)]))) + (let ([addr (+ (mmap-region-addr region) offset)]) + (if (eq? endianness *native-endian*) + ;; Fast path: single 32-bit load + (foreign-ref 'unsigned-32 addr 0) + ;; Slow path: byte-swap + (let ([b0 (foreign-ref 'unsigned-8 addr 0)] + [b1 (foreign-ref 'unsigned-8 addr 1)] + [b2 (foreign-ref 'unsigned-8 addr 2)] + [b3 (foreign-ref 'unsigned-8 addr 3)]) + (case endianness + [(little) + (bitwise-ior b0 + (bitwise-arithmetic-shift b1 8) + (bitwise-arithmetic-shift b2 16) + (bitwise-arithmetic-shift b3 24))] + [(big) + (bitwise-ior (bitwise-arithmetic-shift b0 24) + (bitwise-arithmetic-shift b1 16) + (bitwise-arithmetic-shift b2 8) + b3)]))))) (define (mmap-u32-set! region offset val endianness) (mmap-check-bounds region offset 4 'mmap-u32-set!) (let ([addr (+ (mmap-region-addr region) offset)]) - (case endianness - [(little) - (foreign-set! 'unsigned-8 addr 0 (bitwise-and val #xff)) - (foreign-set! 'unsigned-8 addr 1 (bitwise-and (bitwise-arithmetic-shift val -8) #xff)) - (foreign-set! 'unsigned-8 addr 2 (bitwise-and (bitwise-arithmetic-shift val -16) #xff)) - (foreign-set! 'unsigned-8 addr 3 (bitwise-and (bitwise-arithmetic-shift val -24) #xff))] - [(big) - (foreign-set! 'unsigned-8 addr 0 (bitwise-and (bitwise-arithmetic-shift val -24) #xff)) - (foreign-set! 'unsigned-8 addr 1 (bitwise-and (bitwise-arithmetic-shift val -16) #xff)) - (foreign-set! 'unsigned-8 addr 2 (bitwise-and (bitwise-arithmetic-shift val -8) #xff)) - (foreign-set! 'unsigned-8 addr 3 (bitwise-and val #xff))]))) + (if (eq? endianness *native-endian*) + ;; Fast path: single 32-bit store + (foreign-set! 'unsigned-32 addr 0 val) + ;; Slow path: byte-swap + (case endianness + [(little) + (foreign-set! 'unsigned-8 addr 0 (bitwise-and val #xff)) + (foreign-set! 'unsigned-8 addr 1 (bitwise-and (bitwise-arithmetic-shift val -8) #xff)) + (foreign-set! 'unsigned-8 addr 2 (bitwise-and (bitwise-arithmetic-shift val -16) #xff)) + (foreign-set! 'unsigned-8 addr 3 (bitwise-and (bitwise-arithmetic-shift val -24) #xff))] + [(big) + (foreign-set! 'unsigned-8 addr 0 (bitwise-and (bitwise-arithmetic-shift val -24) #xff)) + (foreign-set! 'unsigned-8 addr 1 (bitwise-and (bitwise-arithmetic-shift val -16) #xff)) + (foreign-set! 'unsigned-8 addr 2 (bitwise-and (bitwise-arithmetic-shift val -8) #xff)) + (foreign-set! 'unsigned-8 addr 3 (bitwise-and val #xff))])))) (define (mmap-s32-ref region offset endianness) - (let ([u (mmap-u32-ref region offset endianness)]) - (if (>= u #x80000000) (- u #x100000000) u))) + (mmap-check-bounds region offset 4 'mmap-s32-ref) + (let ([addr (+ (mmap-region-addr region) offset)]) + (if (eq? endianness *native-endian*) + (foreign-ref 'integer-32 addr 0) + (let ([u (mmap-u32-ref region offset endianness)]) + (if (>= u #x80000000) (- u #x100000000) u))))) (define (mmap-u64-ref region offset endianness) (mmap-check-bounds region offset 8 'mmap-u64-ref) - (let* ([lo (mmap-u32-ref region offset endianness)] - [hi (mmap-u32-ref region (+ offset 4) endianness)]) - (case endianness - [(little) (bitwise-ior lo (bitwise-arithmetic-shift hi 32))] - [(big) (bitwise-ior (bitwise-arithmetic-shift lo 32) hi)]))) + (let ([addr (+ (mmap-region-addr region) offset)]) + (if (eq? endianness *native-endian*) + ;; Fast path: single 64-bit load + (foreign-ref 'unsigned-64 addr 0) + ;; Slow path: assemble from two 32-bit reads + (let* ([lo (mmap-u32-ref region offset endianness)] + [hi (mmap-u32-ref region (+ offset 4) endianness)]) + (case endianness + [(little) (bitwise-ior lo (bitwise-arithmetic-shift hi 32))] + [(big) (bitwise-ior (bitwise-arithmetic-shift lo 32) hi)]))))) (define (mmap-u64-set! region offset val endianness) (mmap-check-bounds region offset 8 'mmap-u64-set!) - (case endianness - [(little) - (mmap-u32-set! region offset (bitwise-and val #xffffffff) 'little) - (mmap-u32-set! region (+ offset 4) (bitwise-arithmetic-shift val -32) 'little)] - [(big) - (mmap-u32-set! region offset (bitwise-arithmetic-shift val -32) 'big) - (mmap-u32-set! region (+ offset 4) (bitwise-and val #xffffffff) 'big)])) + (let ([addr (+ (mmap-region-addr region) offset)]) + (if (eq? endianness *native-endian*) + ;; Fast path: single 64-bit store + (foreign-set! 'unsigned-64 addr 0 val) + ;; Slow path: split into two 32-bit writes + (case endianness + [(little) + (mmap-u32-set! region offset (bitwise-and val #xffffffff) 'little) + (mmap-u32-set! region (+ offset 4) (bitwise-arithmetic-shift val -32) 'little)] + [(big) + (mmap-u32-set! region offset (bitwise-arithmetic-shift val -32) 'big) + (mmap-u32-set! region (+ offset 4) (bitwise-and val #xffffffff) 'big)])))) (define (mmap-s64-ref region offset endianness) - (let ([u (mmap-u64-ref region offset endianness)]) - (if (>= u (expt 2 63)) (- u (expt 2 64)) u))) + (mmap-check-bounds region offset 8 'mmap-s64-ref) + (let ([addr (+ (mmap-region-addr region) offset)]) + (if (eq? endianness *native-endian*) + (foreign-ref 'integer-64 addr 0) + (let ([u (mmap-u64-ref region offset endianness)]) + (if (>= u (expt 2 63)) (- u (expt 2 64)) u))))) ;;; ========== Copy to/from bytevector ========== new file mode 100644 --- /dev/null +++ b/tests/bench-odb.ss @@ -0,0 +1,243 @@ +#!/usr/bin/env scheme-script +#!chezscheme +;;; bench-odb.ss — Performance benchmarks for jerboa odb +;;; Ported from gerbil-odb/bench.ss +;;; Compare raw mmap baseline vs full ODB with CLOS integration. + +(import (chezscheme) + (std odb) + (std clos) + (std os mmap)) + +;; Ensure libc is loaded for raw mmap FFI calls +(load-shared-object "libc.so.6") + +;;; ---- Benchmark infrastructure ---- +(define *N* 100000) + +(define (fmt-ms ns) + ;; Convert nanoseconds to milliseconds string + (number->string (/ (round (/ ns 100000.0)) 10.0))) + +(define-syntax timed + (syntax-rules () + [(_ label body ...) + (let* ([start (time-utc->date (current-time))] + [t0 (current-time)] + [result (begin body ...)] + [t1 (current-time)] + [elapsed (time-difference t1 t0)] + [ns (+ (* (time-second elapsed) 1000000000) + (time-nanosecond elapsed))]) + (display " ") + (display label) + (display ": ") + (display (fmt-ms ns)) + (display "ms") + (newline) + result)])) + +(define (make-shuffled-indices n) + (let ([v (make-vector n)]) + (do ([i 0 (fx+ i 1)]) ((fx= i n)) + (vector-set! v i i)) + ;; Fisher-Yates shuffle with fixed seed for reproducibility + (random-seed 42) + (do ([i (fx- n 1) (fx- i 1)]) ((fx= i 0)) + (let* ([j (random (fx+ i 1))] + [tmp (vector-ref v i)]) + (vector-set! v i (vector-ref v j)) + (vector-set! v j tmp))) + v)) + +(define test-dir "/tmp/odb-bench") + +(display "================================================================") (newline) +(display (format " jerboa odb Benchmarks — N = ~a" *N*)) (newline) +(display "================================================================") (newline) +(newline) + +;;; ---- Benchmark 1: Raw mmap (baseline, no ODB overhead) ---- +(display "---- Bench 1: Raw mmap (baseline, no ODB) ----") (newline) + +(let* ([file-path "/tmp/odb-bench-raw.dat"] + [file-size (* *N* 16)] ;; 16 bytes per point (2 x s64) + ;; Create the backing file + [fd ((foreign-procedure "open" (string int int) int) + file-path (bitwise-ior #x42 #x200) #o644)] ; O_CREAT|O_RDWR|O_TRUNC + [_ ((foreign-procedure "ftruncate" (int long) int) fd file-size)] + [_ ((foreign-procedure "close" (int) int) fd)] + [region (mmap file-path '#:mode 'read-write)]) + + (timed "Create (raw mmap)" + (do ([i 0 (fx+ i 1)]) ((fx= i *N*)) + (let ([off (fx* i 16)]) + (mmap-u64-set! region off i 'little) + (mmap-u64-set! region (fx+ off 8) (fx* i 2) 'little)))) + + (timed "Seq read (raw mmap)" + (let loop ([i 0] [sum 0]) + (if (fx= i *N*) sum + (loop (fx+ i 1) (+ sum (mmap-u64-ref region (fx* i 16) 'little)))))) + + (let ([ridx (make-shuffled-indices *N*)]) + (timed "Rand read (raw mmap)" + (let loop ([i 0] [sum 0]) + (if (fx= i *N*) sum + (loop (fx+ i 1) + (+ sum (mmap-u64-ref region + (fx* (vector-ref ridx i) 16) 'little))))))) + + (timed "Update (raw mmap)" + (do ([i 0 (fx+ i 1)]) ((fx= i *N*)) + (let ([off (fx* i 16)]) + (mmap-u64-set! region off + (+ (mmap-u64-ref region off 'little) 1) 'little)))) + + (timed "Sync (raw mmap)" + (msync region)) + + (munmap region) + (newline)) + +;;; ---- Benchmark 2: Full ODB with define-persistent-class ---- +(display "---- Bench 2: Full ODB (define-persistent-class + CLOS) ----") (newline) + +(system (string-append "rm -rf " test-dir)) +(odb-open test-dir) + +(define-persistent-class <bench-point> () + ((x :type :s64 :initform 0) + (y :type :s64 :initform 0))) + +(define points (make-vector *N* #f)) + +(timed "Create (odb)" + (do ([i 0 (fx+ i 1)]) ((fx= i *N*)) + (vector-set! points i (odb-make <bench-point> :x i :y (fx* i 2))))) + +(timed "Seq read (odb via odb-slot-ref)" + (let loop ([i 0] [sum 0]) + (if (fx= i *N*) sum + (loop (fx+ i 1) + (+ sum (odb-slot-ref (vector-ref points i) 'x)))))) + +(timed "Seq read (odb via CLOS slot-ref)" + (let loop ([i 0] [sum 0]) + (if (fx= i *N*) sum + (loop (fx+ i 1) + (+ sum (slot-ref (vector-ref points i) 'x)))))) + +(let ([ridx (make-shuffled-indices *N*)]) + (timed "Rand read (odb)" + (let loop ([i 0] [sum 0]) + (if (fx= i *N*) sum + (loop (fx+ i 1) + (+ sum (odb-slot-ref (vector-ref points (vector-ref ridx i)) 'x))))))) + +(timed "Update (odb)" + (do ([i 0 (fx+ i 1)]) ((fx= i *N*)) + (odb-slot-set! (vector-ref points i) 'x + (+ (odb-slot-ref (vector-ref points i) 'x) 1)))) + +(timed "Update (odb via CLOS slot-set!)" + (do ([i 0 (fx+ i 1)]) ((fx= i *N*)) + (slot-set! (vector-ref points i) 'x + (+ (slot-ref (vector-ref points i) 'x) 1)))) + +(timed "Sync+close (odb)" + (odb-sync) + (odb-close)) + +;; Report file sizes +(newline) +(display " Store files:") (newline) +(for-each + (lambda (entry) + (let ([path (string-append test-dir "/" entry)]) + (when (file-exists? path) + (let ([p (open-file-input-port path)]) + (let ([sz (port-length p)]) + (close-port p) + (display (format " ~a: ~a bytes~n" entry sz))))))) + (directory-list test-dir)) +(newline) + +;;; ---- Benchmark 3: Transaction overhead ---- +(display "---- Bench 3: Transaction overhead ----") (newline) + +(system (string-append "rm -rf " test-dir)) +(odb-open test-dir) + +(define-persistent-class <txn-point> () + ((x :type :s64 :initform 0) + (y :type :s64 :initform 0))) + +(define tp (odb-make <txn-point> :x 0 :y 0)) + +(timed "1000 txns x 1 write" + (do ([i 0 (fx+ i 1)]) ((fx= i 1000)) + (with-odb-transaction + (odb-slot-set! tp 'x i)))) + +(timed "1 txn x 1000 writes" + (with-odb-transaction + (do ([i 0 (fx+ i 1)]) ((fx= i 1000)) + (odb-slot-set! tp 'x i)))) + +(odb-close) +(newline) + +;;; ---- Benchmark 4: Region growing stress ---- +(display "---- Bench 4: Region growing (allocate beyond initial capacity) ----") (newline) + +(system (string-append "rm -rf " test-dir)) +(odb-open test-dir) + +(define-persistent-class <grow-point> () + ((x :type :s64 :initform 0))) + +(timed "Create 10K objects (forces region grow)" + (do ([i 0 (fx+ i 1)]) ((fx= i 10000)) + (odb-make <grow-point> :x i))) + +(timed "Verify last object" + (odb-find '<grow-point> (lambda (obj) (= (odb-slot-ref obj 'x) 9999)))) + +(odb-close) +(newline) + +;;; ---- Benchmark 5: doclass iteration throughput ---- +(display "---- Bench 5: Iteration throughput ----") (newline) + +(system (string-append "rm -rf " test-dir)) +(odb-open test-dir) + +(define-persistent-class <iter-point> () + ((x :type :s64 :initform 0) + (y :type :s64 :initform 0))) + +;; Create 50K objects +(do ([i 0 (fx+ i 1)]) ((fx= i 50000)) + (odb-make <iter-point> :x i :y (fx* i 3))) + +(timed "doclass 50K objects (sum x)" + (let ([sum 0]) + (doclass (p <iter-point>) + (set! sum (+ sum (odb-slot-ref p 'x)))) + sum)) + +(timed "odb-filter 50K (x > 25000)" + (length (odb-filter '<iter-point> (lambda (obj) + (> (odb-slot-ref obj 'x) 25000))))) + +(timed "odb-count" + (odb-count '<iter-point>)) + +(odb-close) +(newline) + +;;; ---- Summary ---- +(display "================================================================") (newline) +(display " Done.") (newline) +(display "================================================================") (newline)