;
; gpu-atomspace.scm — Phase 7: GPU-Native AtomSpace Scheme Bridge
;
; Wraps libgpu-atomspace.so via Guile FFI. Provides high-level API
; for corpus-learning.scm to use the full GPU pipeline:
;
; count_sentences → compute_mi → extract_sections →
; cosine_candidates → assign_classes → substitute
;
; Usage:
; (load "gpu-atomspace.scm")
; (gpu-init!)
; (gpu-process-sentences! '(("the" "cat" "sat") ("a" "dog" "ran")))
; (gpu-native-compute-mi!)
; (gpu-status)
; (gpu-shutdown!)
;
(use-modules (system foreign)
(rnrs bytevectors)
(ice-9 format)
(ice-9 hash-table)
(srfi srfi-1))
; ═══════════════════════════════════════════════════════════════════
; FFI SETUP
; ═══════════════════════════════════════════════════════════════════
(define *gpu-lib* #f)
(define *gpu-native-ready* #f)
(define *mvp-dir*
"/storage/projects/code/hypercore-kb/opencog-kb/language-learning/mvp")
(define *kernel-dir*
"/storage/projects/code/hypercore-kb/opencog-kb/repos/atomese-simd/opencog/opencl/atomspace")
; Word mapping: string → GPU pool index
(define *word-to-index* (make-hash-table))
(define *index-to-word* (make-hash-table))
(define *next-word-hash* 1000) ; start above reserved range
; ─── Load library and bind functions ───
(define (load-gpu-lib!)
(set! *gpu-lib*
(dynamic-link (string-append *mvp-dir* "/libgpu-atomspace")))
; int gpu_init(const char* kernel_dir)
(define-values () (values)) ; placeholder
*gpu-lib*)
(define (gpu-func name ret-type arg-types)
"Create a callable from the GPU library."
(pointer->procedure ret-type
(dynamic-func name *gpu-lib*) arg-types))
; ═══════════════════════════════════════════════════════════════════
; WORD HASHING
; ═══════════════════════════════════════════════════════════════════
(define (fnv1a-hash str)
"FNV-1a 64-bit hash of a string. Returns uint64."
(let loop ((h #xcbf29ce484222325)
(chars (string->list str)))
(if (null? chars)
(logand h #xFFFFFFFFFFFFFFFF)
(loop (logand
(* (logxor h (char->integer (car chars)))
#x100000001b3)
#xFFFFFFFFFFFFFFFF)
(cdr chars)))))
; ═══════════════════════════════════════════════════════════════════
; GPU INIT / SHUTDOWN
; ═══════════════════════════════════════════════════════════════════
(define (gpu-init!)
"Initialize GPU AtomSpace. Call once at startup."
(when *gpu-native-ready*
(format #t "GPU already initialized\n")
(values))
(load-gpu-lib!)
(let* ((f-init (gpu-func "gpu_init" int (list '*)))
(dir-bv (string->pointer *kernel-dir*))
(ret (f-init dir-bv)))
(if (= ret 0)
(begin
(set! *gpu-native-ready* #t)
(format #t "GPU AtomSpace initialized\n"))
(error "gpu_init failed" ret))))
(define (gpu-shutdown!)
"Release GPU resources."
(when *gpu-native-ready*
(let ((f-shutdown (gpu-func "gpu_shutdown" void '())))
(f-shutdown)
(set! *gpu-native-ready* #f)
(hash-clear! *word-to-index*)
(hash-clear! *index-to-word*)
(format #t "GPU shutdown\n"))))
; ═══════════════════════════════════════════════════════════════════
; WORD REGISTRATION
; ═══════════════════════════════════════════════════════════════════
(define (gpu-ensure-words! word-list)
"Register words on GPU if not already known.
Returns list of pool indices in same order as word-list."
;; Find new words (skip empty strings)
(define new-words
(filter (lambda (w) (and (> (string-length w) 0)
(not (hashq-ref *word-to-index* (string->symbol w)))))
(delete-duplicates word-list string=?)))
(when (not (null? new-words))
(let* ((n (length new-words))
;; Build hash array
(hash-bv (make-bytevector (* n 8)))
(out-bv (make-bytevector (* n 4)))
(hashes (map fnv1a-hash new-words)))
;; Fill hash bytevector
(let loop ((i 0) (hs hashes))
(when (not (null? hs))
(bytevector-u64-native-set! hash-bv (* i 8) (car hs))
(loop (+ i 1) (cdr hs))))
;; Call GPU
(let* ((f-reg (gpu-func "gpu_register_words"
int (list '* '* int)))
(ret (f-reg (bytevector->pointer hash-bv)
(bytevector->pointer out-bv) n)))
;; Store mappings
(let loop ((i 0) (ws new-words))
(when (not (null? ws))
(let ((idx (bytevector-u32-native-ref out-bv (* i 4)))
(sym (string->symbol (car ws))))
(hashq-set! *word-to-index* sym idx)
(hashv-set! *index-to-word* idx (car ws)))
(loop (+ i 1) (cdr ws)))))))
;; Return indices for all words in order
(map (lambda (w) (hashq-ref *word-to-index* (string->symbol w)))
word-list))
; ═══════════════════════════════════════════════════════════════════
; SENTENCE PROCESSING
; ═══════════════════════════════════════════════════════════════════
(define* (gpu-process-sentences! sentences #:key (window 6))
"Process a batch of sentences on GPU.
sentences: list of (list-of-word-strings).
Counts all word pairs within window."
(when (not *gpu-native-ready*) (error "GPU not initialized"))
;; Filter empty strings from each sentence
(define clean-sentences
(map (lambda (s) (filter (lambda (w) (> (string-length w) 0)) s))
sentences))
;; Collect all words and register
(define all-words (apply append clean-sentences))
(define indices (gpu-ensure-words! all-words))
;; Build flat arrays
(define n-sents (length clean-sentences))
(define total-words (length all-words))
(define flat-bv (make-bytevector (* total-words 4)))
(define off-bv (make-bytevector (* n-sents 4)))
(define len-bv (make-bytevector (* n-sents 4)))
;; Fill flat_words with pool indices
(let loop ((i 0) (idxs indices))
(when (not (null? idxs))
(bytevector-u32-native-set! flat-bv (* i 4) (car idxs))
(loop (+ i 1) (cdr idxs))))
;; Fill offsets and lengths
(let loop ((s 0) (sents clean-sentences) (offset 0))
(when (not (null? sents))
(let ((slen (length (car sents))))
(bytevector-u32-native-set! off-bv (* s 4) offset)
(bytevector-u32-native-set! len-bv (* s 4) slen)
(loop (+ s 1) (cdr sents) (+ offset slen)))))
;; Call GPU
(let ((f-count (gpu-func "gpu_count_sentences"
int (list '* '* '* int int int))))
(f-count (bytevector->pointer flat-bv)
(bytevector->pointer off-bv)
(bytevector->pointer len-bv)
n-sents total-words window))
(format #t "Counted ~a sentences (~a words)\n" n-sents total-words))
; ═══════════════════════════════════════════════════════════════════
; MI COMPUTATION
; ═══════════════════════════════════════════════════════════════════
(define* (gpu-native-compute-mi! #:key (dirty-only #f))
"Compute MI for all pairs (or dirty only) on GPU-native AtomSpace."
(when (not *gpu-native-ready*) (error "GPU not initialized"))
(let* ((f-mi (gpu-func "gpu_compute_mi" int (list int)))
(n (f-mi (if dirty-only 1 0))))
(format #t "MI computed for ~a pairs~a\n" n
(if dirty-only " (dirty only)" ""))
n))
; ═══════════════════════════════════════════════════════════════════
; PAIR READBACK
; ═══════════════════════════════════════════════════════════════════
(define* (gpu-read-pairs #:key (max-pairs 1000000))
"Download pair data from GPU.
Returns list of (word-a-str word-b-str count mi)."
(when (not *gpu-native-ready*) (error "GPU not initialized"))
(let* ((wa-bv (make-bytevector (* max-pairs 4)))
(wb-bv (make-bytevector (* max-pairs 4)))
(cnt-bv (make-bytevector (* max-pairs 8)))
(mi-bv (make-bytevector (* max-pairs 8)))
(f-read (gpu-func "gpu_read_pair_data"
int (list '* '* '* '* int)))
(n (f-read (bytevector->pointer wa-bv)
(bytevector->pointer wb-bv)
(bytevector->pointer cnt-bv)
(bytevector->pointer mi-bv)
max-pairs)))
;; Convert to list
(let loop ((i 0) (result '()))
(if (>= i n) (reverse result)
(let* ((wa (bytevector-u32-native-ref wa-bv (* i 4)))
(wb (bytevector-u32-native-ref wb-bv (* i 4)))
(cnt (bytevector-ieee-double-native-ref cnt-bv (* i 8)))
(mi (bytevector-ieee-double-native-ref mi-bv (* i 8)))
(wa-str (or (hashv-ref *index-to-word* wa)
(format #f "w~a" wa)))
(wb-str (or (hashv-ref *index-to-word* wb)
(format #f "w~a" wb))))
(if (> cnt 0.5)
(loop (+ i 1)
(cons (list wa-str wb-str cnt mi) result))
(loop (+ i 1) result)))))))
; ═══════════════════════════════════════════════════════════════════
; COSINE CANDIDATES
; ═══════════════════════════════════════════════════════════════════
(define* (gpu-cosine-candidates #:key (threshold 0.3) (max-output 10000))
"Run full cosine pipeline on GPU sections.
Returns list of (word-a-str word-b-str cosine) sorted by cosine desc."
(when (not *gpu-native-ready*) (error "GPU not initialized"))
(let* ((wa-bv (make-bytevector (* max-output 4)))
(wb-bv (make-bytevector (* max-output 4)))
(cos-bv (make-bytevector (* max-output 8)))
(f-cos (gpu-func "gpu_cosine_pipeline"
int (list double '* '* '* int)))
(n (f-cos threshold
(bytevector->pointer wa-bv)
(bytevector->pointer wb-bv)
(bytevector->pointer cos-bv)
max-output)))
;; Convert and sort
(let loop ((i 0) (result '()))
(if (>= i n)
(sort (reverse result)
(lambda (a b) (> (caddr a) (caddr b))))
(let* ((wa (bytevector-u32-native-ref wa-bv (* i 4)))
(wb (bytevector-u32-native-ref wb-bv (* i 4)))
(cos-val (bytevector-ieee-double-native-ref cos-bv (* i 8)))
(wa-str (or (hashv-ref *index-to-word* wa)
(format #f "w~a" wa)))
(wb-str (or (hashv-ref *index-to-word* wb)
(format #f "w~a" wb))))
(loop (+ i 1)
(cons (list wa-str wb-str cos-val) result)))))))
; ═══════════════════════════════════════════════════════════════════
; SECTION EXTRACTION
; ═══════════════════════════════════════════════════════════════════
(define (gpu-extract-sections! sentences mst-edges)
"Extract sections from sentences + MST edge data on GPU.
sentences: list of (list-of-word-strings)
mst-edges: list of (list-of (p1 . p2)) — position pairs per sentence"
(when (not *gpu-native-ready*) (error "GPU not initialized"))
(define all-words (apply append sentences))
(define indices (gpu-ensure-words! all-words))
(define n-sents (length sentences))
(define total-words (length all-words))
;; Flatten edges
(define all-edges (apply append mst-edges))
(define total-edges (length all-edges))
;; Build bytevectors
(define flat-bv (make-bytevector (* total-words 4)))
(define off-bv (make-bytevector (* n-sents 4)))
(define len-bv (make-bytevector (* n-sents 4)))
(define ep1-bv (make-bytevector (* (max total-edges 1) 4)))
(define ep2-bv (make-bytevector (* (max total-edges 1) 4)))
(define eoff-bv (make-bytevector (* n-sents 4)))
(define ecnt-bv (make-bytevector (* n-sents 4)))
;; Fill flat_words
(let loop ((i 0) (idxs indices))
(when (not (null? idxs))
(bytevector-u32-native-set! flat-bv (* i 4) (car idxs))
(loop (+ i 1) (cdr idxs))))
;; Fill sentence offsets/lengths and edge offsets/counts
(let loop ((s 0) (sents sentences) (edges mst-edges)
(w-off 0) (e-off 0))
(when (not (null? sents))
(let ((slen (length (car sents)))
(elen (length (car edges))))
(bytevector-u32-native-set! off-bv (* s 4) w-off)
(bytevector-u32-native-set! len-bv (* s 4) slen)
(bytevector-u32-native-set! eoff-bv (* s 4) e-off)
(bytevector-u32-native-set! ecnt-bv (* s 4) elen)
;; Fill edge positions
(let eloop ((ei 0) (es (car edges)))
(when (not (null? es))
(bytevector-u32-native-set! ep1-bv (* (+ e-off ei) 4) (caar es))
(bytevector-u32-native-set! ep2-bv (* (+ e-off ei) 4) (cdar es))
(eloop (+ ei 1) (cdr es))))
(loop (+ s 1) (cdr sents) (cdr edges)
(+ w-off slen) (+ e-off elen)))))
;; Call GPU
(let ((f-sec (gpu-func "gpu_extract_sections"
int (list '* '* '* '* '* '* '* int int int))))
(f-sec (bytevector->pointer flat-bv)
(bytevector->pointer off-bv)
(bytevector->pointer len-bv)
(bytevector->pointer ep1-bv)
(bytevector->pointer ep2-bv)
(bytevector->pointer eoff-bv)
(bytevector->pointer ecnt-bv)
n-sents total-words total-edges))
(format #t "Sections extracted from ~a sentences (~a edges)\n"
n-sents total-edges))
; ═══════════════════════════════════════════════════════════════════
; BULK LOAD FROM COGSERVER
;
; Copies *sections* + *section-counts* directly to GPU, eliminating
; the need to re-count sentences on GPU. One call replaces 35s of
; FFI counting with a single bulk upload.
; ═══════════════════════════════════════════════════════════════════
(define (gpu-load-cogserver-sections!)
"Bulk-load CogServer's section data to GPU.
Reads *sections* and *section-counts* (defined in run-cogserver.scm).
Replaces any existing GPU section data."
(when (not *gpu-native-ready*) (error "GPU not initialized"))
(let ((t0 (get-internal-real-time))
(entries '()))
;; Collect all (word, disjunct, count) triples
(hash-for-each
(lambda (word disj-list)
(when (and (string? word) (> (string-length word) 0))
(for-each
(lambda (d)
(let ((count (hash-ref *section-counts* (cons word d) 0)))
(when (> count 0)
(set! entries (cons (list word d count) entries)))))
disj-list)))
*sections*)
(let ((n (length entries)))
(if (= n 0)
(format #t "No sections to load~%")
(begin
(format #t "Loading ~a sections to GPU..." n)
;; Register all unique words
(let ((words (delete-duplicates (map car entries) string=?)))
(gpu-ensure-words! words))
;; Build bytevectors
(let ((wid-bv (make-bytevector (* n 4)))
(djh-bv (make-bytevector (* n 8)))
(cnt-bv (make-bytevector (* n 8))))
(let loop ((i 0) (es entries))
(when (not (null? es))
(let* ((e (car es))
(word (car e))
(disj (cadr e))
(count (caddr e))
(widx (hashq-ref *word-to-index* (string->symbol word)))
(djh (fnv1a-hash disj)))
(when widx
(bytevector-u32-native-set! wid-bv (* i 4) widx)
(bytevector-u64-native-set! djh-bv (* i 8) djh)
(bytevector-ieee-double-native-set! cnt-bv (* i 8)
(exact->inexact count))))
(loop (+ i 1) (cdr es))))
;; Call C function
(let ((f-load (gpu-func "gpu_bulk_load_sections"
int (list '* '* '* int))))
(f-load (bytevector->pointer wid-bv)
(bytevector->pointer djh-bv)
(bytevector->pointer cnt-bv)
n)))
(let ((elapsed (/ (- (get-internal-real-time) t0) 1e9)))
(format #t " done in ~,2fs (~a words)~%"
elapsed (hash-count (const #t) *word-to-index*))))))))
; ═══════════════════════════════════════════════════════════════════
; CLASS MANAGEMENT
; ═══════════════════════════════════════════════════════════════════
(define (gpu-assign-classes! assignments)
"Set word→class assignments on GPU.
assignments: list of (word-string . class-id)"
(when (not *gpu-native-ready*) (error "GPU not initialized"))
(let* ((n (length assignments))
(wid-bv (make-bytevector (* n 4)))
(cid-bv (make-bytevector (* n 4))))
(let loop ((i 0) (as assignments))
(when (not (null? as))
(let* ((a (car as))
(widx (hashq-ref *word-to-index*
(string->symbol (car a)))))
(when widx
(bytevector-u32-native-set! wid-bv (* i 4) widx)
(bytevector-u32-native-set! cid-bv (* i 4) (cdr a))))
(loop (+ i 1) (cdr as))))
(let ((f-assign (gpu-func "gpu_assign_classes"
int (list '* '* int))))
(f-assign (bytevector->pointer wid-bv)
(bytevector->pointer cid-bv) n))
(format #t "Assigned ~a words to classes\n" n)))
(define (gpu-substitute!)
"Run full substitution pipeline on GPU.
Returns (changed eliminated merged)."
(when (not *gpu-native-ready*) (error "GPU not initialized"))
(let* ((ch-bv (make-bytevector 4))
(el-bv (make-bytevector 4))
(mg-bv (make-bytevector 4))
(f-sub (gpu-func "gpu_substitute"
int (list '* '* '*)))
(ret (f-sub (bytevector->pointer ch-bv)
(bytevector->pointer el-bv)
(bytevector->pointer mg-bv)))
(changed (bytevector-u32-native-ref ch-bv 0))
(eliminated (bytevector-u32-native-ref el-bv 0))
(merged (bytevector-u32-native-ref mg-bv 0)))
(format #t "Substitute: changed=~a eliminated=~a merged=~a\n"
changed eliminated merged)
(list changed eliminated merged)))
; ═══════════════════════════════════════════════════════════════════
; STATISTICS
; ═══════════════════════════════════════════════════════════════════
(define (gpu-status)
"Print GPU AtomSpace statistics."
(when (not *gpu-native-ready*) (error "GPU not initialized"))
(let* ((nw-bv (make-bytevector 4))
(np-bv (make-bytevector 4))
(ns-bv (make-bytevector 4))
(f-stats (gpu-func "gpu_get_stats"
int (list '* '* '*)))
(ret (f-stats (bytevector->pointer nw-bv)
(bytevector->pointer np-bv)
(bytevector->pointer ns-bv)))
(nw (bytevector-u32-native-ref nw-bv 0))
(np (bytevector-u32-native-ref np-bv 0))
(ns (bytevector-u32-native-ref ns-bv 0)))
(format #t "GPU AtomSpace: ~a words, ~a pairs, ~a sections\n" nw np ns)
(list nw np ns)))
; ═══════════════════════════════════════════════════════════════════
; CONNECTOR COSINE — brute-force pairwise on dense matrix
; ═══════════════════════════════════════════════════════════════════
(define* (gpu-connector-cosine-candidates! word-list
#:key (threshold 0.01) (max-output 50000))
"Build dense connector matrix from *cl-connector-index* (must be populated),
run GPU brute-force pairwise cosine, return sorted list: ((cosine w1 w2) ...)."
(when (not *gpu-native-ready*) (error "GPU not initialized"))
(let* ((n-words (length word-list))
(word-vec (list->vector word-list))
;; Build connector → column index mapping
(all-conns (make-hash-table))
(conn-idx 0))
;; Collect all unique connectors
(for-each
(lambda (w)
(let ((conn-hash (hash-ref *cl-connector-index* w #f)))
(when conn-hash
(hash-for-each
(lambda (conn _)
(unless (hash-ref all-conns conn #f)
(hash-set! all-conns conn conn-idx)
(set! conn-idx (+ conn-idx 1))))
conn-hash))))
word-list)
(let ((n-conn conn-idx))
(if (or (< n-words 2) (< n-conn 1))
'() ; nothing to compute
(let* (;; Build dense float matrix: word-row × conn-col
(matrix-bv (make-bytevector (* n-words n-conn 4) 0)) ; float = 4 bytes
;; Fill matrix
(_ (let fill-loop ((i 0) (ws word-list))
(when (not (null? ws))
(let ((w (car ws))
(base (* i n-conn 4)))
(let ((conn-hash (hash-ref *cl-connector-index* w #f)))
(when conn-hash
(hash-for-each
(lambda (conn count)
(let ((col (hash-ref all-conns conn #f)))
(when col
(bytevector-ieee-single-native-set!
matrix-bv (+ base (* col 4))
(exact->inexact count)))))
conn-hash))))
(fill-loop (+ i 1) (cdr ws)))))
;; Output buffers
(out-wa-bv (make-bytevector (* max-output 4)))
(out-wb-bv (make-bytevector (* max-output 4)))
(out-cos-bv (make-bytevector (* max-output 4))) ; float
;; Call C function
(f-cc (gpu-func "gpu_connector_cosine"
int (list '* int int float '* '* '* int)))
(n-out (f-cc (bytevector->pointer matrix-bv)
n-words n-conn threshold
(bytevector->pointer out-wa-bv)
(bytevector->pointer out-wb-bv)
(bytevector->pointer out-cos-bv)
max-output)))
(format #t "GPU connector-cosine: ~a words × ~a conns → ~a candidates~%"
n-words n-conn n-out)
;; Convert indices back to word strings and build result list
(let ((results '()))
(do ((k 0 (+ k 1))) ((>= k n-out))
(let ((wa (bytevector-u32-native-ref out-wa-bv (* k 4)))
(wb (bytevector-u32-native-ref out-wb-bv (* k 4)))
(cos-val (bytevector-ieee-single-native-ref out-cos-bv (* k 4))))
(when (and (< wa n-words) (< wb n-words))
(set! results
(cons (list cos-val
(vector-ref word-vec wa)
(vector-ref word-vec wb))
results)))))
;; Sort by cosine descending
(sort results (lambda (a b) (> (car a) (car b))))))))))
; ═══════════════════════════════════════════════════════════════════
; HIGH-LEVEL API (for corpus-learning.scm integration)
; ═══════════════════════════════════════════════════════════════════
(define (gpu-bootstrap!)
"Initialize GPU and prepare for corpus processing."
(gpu-init!)
(format #t "GPU AtomSpace bootstrapped and ready\n"))
(define* (gpu-run-corpus sentences #:key (window 6) (cluster-every 2000)
(cosine-threshold 0.3))
"Process sentences on GPU with periodic clustering.
sentences: list of (list-of-word-strings)."
(when (not *gpu-native-ready*) (gpu-bootstrap!))
(let* ((total (length sentences))
(processed 0))
(let loop ((remaining sentences) (batch '()) (batch-n 0))
(cond
;; Done
((null? remaining)
(when (not (null? batch))
(gpu-process-sentences! (reverse batch) #:window window)
(set! processed (+ processed (length batch))))
(format #t "Processed ~a/~a sentences\n" processed total))
;; Batch full → process + maybe cluster
((>= batch-n cluster-every)
(gpu-process-sentences! (reverse batch) #:window window)
(set! processed (+ processed batch-n))
(format #t "~a/~a sentences processed\n" processed total)
;; Clustering round
(format #t "--- Clustering round ---\n")
(gpu-native-compute-mi!)
(gpu-status)
(loop remaining '() 0))
;; Accumulate
(else
(loop (cdr remaining)
(cons (car remaining) batch)
(+ batch-n 1)))))))
(define (gpu-corpus-status)
"Show GPU corpus status."
(when (not *gpu-native-ready*)
(format #t "GPU not initialized\n")
(values))
(gpu-status)
(let* ((f-obs (gpu-func "gpu_get_total_observations"
uint32 '()))
(n-obs (f-obs)))
(format #t "Total pair observations: ~a\n" n-obs)))