Splat a bunch of modules from elsewhere.
This commit is contained in:
David Thompson
parent
7d728559d0
commit
1b950264d1
11 changed files with 3861 additions and 376 deletions
43
modules/goblins/abstract-types.scm
Normal file
43
modules/goblins/abstract-types.scm
Normal file
|
|
@ -0,0 +1,43 @@
|
|||
;;; Copyright 2023 Jessica Tallon
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
(define-module (goblins abstract-types)
|
||||
#:export (zilch
|
||||
zilch?
|
||||
|
||||
<tagged>
|
||||
make-tagged
|
||||
make-tagged*
|
||||
tagged?
|
||||
tagged-label
|
||||
tagged-data))
|
||||
|
||||
;; This is both a 2nd and secondary "bottom" or null/void type that's used
|
||||
;; within CapTP. This works alongside guile's *unspecified* bottom type.
|
||||
(define (make-zilch)
|
||||
(define-record-type <zilch>
|
||||
(_make-zilch)
|
||||
zilch?)
|
||||
(values (_make-zilch) zilch?))
|
||||
|
||||
(define-values (zilch zilch?)
|
||||
(make-zilch))
|
||||
|
||||
(define-record-type <tagged>
|
||||
(make-tagged label data)
|
||||
tagged?
|
||||
(label tagged-label)
|
||||
(data tagged-data))
|
||||
|
||||
(define (make-tagged* label . args)
|
||||
(make-tagged label args))
|
||||
237
modules/goblins/core-types.scm
Normal file
237
modules/goblins/core-types.scm
Normal file
|
|
@ -0,0 +1,237 @@
|
|||
;;; Copyright 2019-2023 Christine Lemmer-Webber
|
||||
;;; Copyright 2023 David Thompson
|
||||
;;; Copyright 2022-2024 Jessica Tallon
|
||||
;;; Copyright 2023 Juliana Sims
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
|
||||
;; This module should largely be considered private and should typically
|
||||
;; not be used directly. If you need these things, most of them are
|
||||
;; exported from core and if they haven't been, likely it's because you
|
||||
;; don't need them.
|
||||
(define-module (goblins core-types)
|
||||
#:use-module (hoot hashtables)
|
||||
#:use-module (ice-9 match)
|
||||
#:export (<actormap>
|
||||
_make-actormap
|
||||
actormap?
|
||||
actormap-metatype
|
||||
actormap-data
|
||||
actormap-vat-connector
|
||||
actormap-ref
|
||||
actormap-set!
|
||||
|
||||
<actormap-metatype>
|
||||
make-actormap-metatype
|
||||
actormap-metatype?
|
||||
actormap-metatype-name
|
||||
actormap-metatype-ref-proc
|
||||
actormap-metatype-set!-proc
|
||||
|
||||
<whactormap-data>
|
||||
make-whactormap-data
|
||||
whactormap-data?
|
||||
whactormap-data-wht
|
||||
|
||||
whactormap?
|
||||
whactormap-ref
|
||||
whactormap-set!
|
||||
whactormap-metatype
|
||||
|
||||
<transactormap-data>
|
||||
make-transactormap-data
|
||||
transactormap-data?
|
||||
transactormap-data-parent
|
||||
transactormap-data-delta
|
||||
transactormap-data-merged?
|
||||
set-transactormap-data-merged?!
|
||||
transactormap-merged?
|
||||
|
||||
<local-object-refr>
|
||||
make-local-object-refr
|
||||
local-object-refr?
|
||||
local-object-refr-debug-name
|
||||
local-object-refr-vat-connector
|
||||
|
||||
<local-promise-refr>
|
||||
make-local-promise-refr
|
||||
local-promise-refr?
|
||||
local-promise-refr-vat-connector
|
||||
|
||||
<remote-object-refr>
|
||||
make-remote-object-refr
|
||||
remote-object-refr?
|
||||
remote-object-refr-captp-connector
|
||||
remote-object-refr-sealed-pos
|
||||
|
||||
<remote-promise-refr>
|
||||
make-remote-promise-refr
|
||||
remote-promise-refr?
|
||||
remote-promise-refr-captp-connector
|
||||
remote-promise-refr-sealed-pos
|
||||
|
||||
local-refr?
|
||||
local-refr-vat-connector
|
||||
remote-refr?
|
||||
remote-refr-captp-connector
|
||||
remote-refr-sealed-pos
|
||||
live-refr?
|
||||
promise-refr?))
|
||||
|
||||
;; hoot hacks
|
||||
|
||||
(define *unspecified* (if #f #f))
|
||||
|
||||
;; Actormaps, etc
|
||||
;; ==============
|
||||
(define-record-type <actormap>
|
||||
;; TODO: This is confusing, naming-wise? (see make-actormap alias)
|
||||
(_make-actormap metatype data vat-connector)
|
||||
actormap?
|
||||
(metatype actormap-metatype)
|
||||
(data actormap-data)
|
||||
(vat-connector actormap-vat-connector))
|
||||
|
||||
(define-record-type <actormap-metatype>
|
||||
(make-actormap-metatype name ref-proc set!-proc)
|
||||
actormap-metatype?
|
||||
(name actormap-metatype-name)
|
||||
(ref-proc actormap-metatype-ref-proc)
|
||||
(set!-proc actormap-metatype-set!-proc))
|
||||
|
||||
(define (actormap-set! am key val)
|
||||
((actormap-metatype-set!-proc (actormap-metatype am))
|
||||
am key val)
|
||||
*unspecified*)
|
||||
|
||||
;; (-> actormap? local-refr? (or/c mactor? #f))
|
||||
(define (actormap-ref am key)
|
||||
((actormap-metatype-ref-proc (actormap-metatype am)) am key))
|
||||
|
||||
(define-record-type <whactormap-data>
|
||||
(make-whactormap-data wht)
|
||||
whactormap-data?
|
||||
(wht whactormap-data-wht))
|
||||
|
||||
(define (whactormap? obj)
|
||||
"Return #t if OBJ is a weak-hash actormap, else #f.
|
||||
|
||||
Type: Any -> Boolean"
|
||||
(and (actormap? obj)
|
||||
(eq? (actormap-metatype obj) whactormap-metatype)))
|
||||
|
||||
(define (whactormap-ref am key)
|
||||
(define wht (whactormap-data-wht (actormap-data am)))
|
||||
(weak-key-hashtable-ref wht key #f))
|
||||
|
||||
(define (whactormap-set! am key val)
|
||||
(define wht (whactormap-data-wht (actormap-data am)))
|
||||
(weak-key-hashtable-set! wht key val))
|
||||
|
||||
(define whactormap-metatype
|
||||
(make-actormap-metatype 'whactormap whactormap-ref whactormap-set!))
|
||||
|
||||
;; Transactional actormaps
|
||||
;; =======================
|
||||
|
||||
(define-record-type <transactormap-data>
|
||||
(make-transactormap-data parent delta merged?)
|
||||
transactormap-data?
|
||||
(parent transactormap-data-parent)
|
||||
(delta transactormap-data-delta)
|
||||
(merged? transactormap-data-merged? set-transactormap-data-merged?!))
|
||||
|
||||
(define (transactormap-merged? transactormap)
|
||||
(transactormap-data-merged? (actormap-data transactormap)))
|
||||
|
||||
;; Ref(r)s
|
||||
;; =======
|
||||
|
||||
(define-record-type <local-object-refr>
|
||||
(make-local-object-refr debug-name vat-connector)
|
||||
local-object-refr?
|
||||
(debug-name local-object-refr-debug-name)
|
||||
(vat-connector local-object-refr-vat-connector))
|
||||
|
||||
(define-record-type <local-promise-refr>
|
||||
(make-local-promise-refr vat-connector)
|
||||
local-promise-refr?
|
||||
(vat-connector local-promise-refr-vat-connector))
|
||||
|
||||
(define (local-refr? obj)
|
||||
"Return #t if OBJ is an object or promise reference in the current
|
||||
process, else #f.
|
||||
|
||||
Type: Any -> Boolean"
|
||||
(or (local-object-refr? obj) (local-promise-refr? obj)))
|
||||
|
||||
(define (local-refr-vat-connector local-refr)
|
||||
(match local-refr
|
||||
[(? local-object-refr?)
|
||||
(local-object-refr-vat-connector local-refr)]
|
||||
[(? local-promise-refr?)
|
||||
(local-promise-refr-vat-connector local-refr)]))
|
||||
|
||||
;; Captp-connector should be a procedure which both sends a message
|
||||
;; to the local node representative actor, but also has something
|
||||
;; serialized that knows which specific remote node + session this
|
||||
;; corresponds to (to look up the right captp session and forward)
|
||||
|
||||
(define-record-type <remote-object-refr>
|
||||
(make-remote-object-refr captp-connector sealed-pos)
|
||||
remote-object-refr?
|
||||
(captp-connector remote-object-refr-captp-connector)
|
||||
(sealed-pos remote-object-refr-sealed-pos))
|
||||
|
||||
(define-record-type <remote-promise-refr>
|
||||
(make-remote-promise-refr captp-connector sealed-pos)
|
||||
remote-promise-refr?
|
||||
(captp-connector remote-promise-refr-captp-connector)
|
||||
(sealed-pos remote-promise-refr-sealed-pos))
|
||||
|
||||
(define (promise-refr? maybe-promise)
|
||||
"Return #t if MAYBE-PROMISE is a promise reference, else #f.
|
||||
|
||||
Type: Any -> Boolean"
|
||||
(or (local-promise-refr? maybe-promise) (remote-promise-refr? maybe-promise)))
|
||||
|
||||
(define (remote-refr-captp-connector remote-refr)
|
||||
(match remote-refr
|
||||
[(? remote-object-refr?)
|
||||
(remote-object-refr-captp-connector remote-refr)]
|
||||
[(? remote-promise-refr?)
|
||||
(remote-promise-refr-captp-connector remote-refr)]))
|
||||
|
||||
(define (remote-refr-sealed-pos remote-refr)
|
||||
(match remote-refr
|
||||
[(? remote-object-refr?)
|
||||
(remote-object-refr-sealed-pos remote-refr)]
|
||||
[(? remote-promise-refr?)
|
||||
(remote-promise-refr-sealed-pos remote-refr)]))
|
||||
|
||||
(define (remote-refr? obj)
|
||||
"Return #t if OBJ is an object or promise reference in a different
|
||||
process, else #f.
|
||||
|
||||
Type: Any -> Boolean"
|
||||
(or (remote-object-refr? obj)
|
||||
(remote-promise-refr? obj)))
|
||||
|
||||
(define (live-refr? obj)
|
||||
"Return #t if OBJ is a local or remote object or promise reference,
|
||||
else #f.
|
||||
|
||||
Type: Any -> Boolean"
|
||||
(or (local-refr? obj)
|
||||
(remote-refr? obj)))
|
||||
2370
modules/goblins/core.scm
Normal file
2370
modules/goblins/core.scm
Normal file
File diff suppressed because it is too large
Load diff
239
modules/goblins/ghash.scm
Normal file
239
modules/goblins/ghash.scm
Normal file
|
|
@ -0,0 +1,239 @@
|
|||
;;; Copyright 2021-2024 Christine Lemmer-Webber
|
||||
;;; Copyright 2024 Jessica Tallon
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
;; An immutable hashtable with specific set/ref conventions. Refrs
|
||||
;; are hashed by eq?, everything else is hashed by equal?.
|
||||
;;
|
||||
;; TODO: Really presently built on top of vhashes. Might be built on
|
||||
;; top of something else, like fashes, in the future. Especially since
|
||||
;; vhashes are not thread safe...
|
||||
|
||||
|
||||
(define-module (goblins ghash)
|
||||
;; NOTE: Do not depend on core because it depends on us.
|
||||
#:use-module (goblins core-types)
|
||||
#:use-module (ice-9 vlist)
|
||||
#:use-module (hoot hashtables)
|
||||
#:use-module ((hoot lists) #:select (fold))
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (scheme write)
|
||||
#:export (make-ghash
|
||||
ghash?
|
||||
|
||||
ghash-set
|
||||
ghash-ref
|
||||
ghash-remove
|
||||
ghash-null
|
||||
ghash-length
|
||||
ghash-has-key?
|
||||
|
||||
ghash-fold
|
||||
ghash-fold-right
|
||||
ghash-for-each
|
||||
|
||||
hashtable->ghash
|
||||
|
||||
make-gset
|
||||
gset?
|
||||
gset-add
|
||||
gset-remove
|
||||
gset-length
|
||||
gset->list
|
||||
gset-member?
|
||||
|
||||
gset-fold
|
||||
gset-for-each))
|
||||
|
||||
;; hoot hacks
|
||||
|
||||
(define (hashtable-fold proc init table)
|
||||
(let ((acc init))
|
||||
(hashtable-for-each
|
||||
(lambda (k v)
|
||||
(set! acc (proc k v acc)))
|
||||
table)))
|
||||
|
||||
(define-record-type <ghash>
|
||||
(_make-ghash vhash)
|
||||
ghash?
|
||||
(vhash ghash-vhash))
|
||||
|
||||
(define (vhash-length vhash)
|
||||
(vhash-fold (lambda (_k _v count) (+ count 1))
|
||||
0 vhash))
|
||||
|
||||
(define (print-ghash vhash port)
|
||||
(display
|
||||
(string-append
|
||||
"#<ghash (" (vhash-length (ghash-vhash vhash)) ")>")
|
||||
port))
|
||||
|
||||
(define ghash-null (_make-ghash vlist-null))
|
||||
|
||||
(define (make-ghash . key-vals)
|
||||
(_make-ghash
|
||||
(let lp ((key-vals key-vals)
|
||||
(vh vlist-null))
|
||||
(match key-vals
|
||||
[() vh]
|
||||
[(key val . rest)
|
||||
(lp rest
|
||||
(_vh-set vh key val))]))))
|
||||
|
||||
(define (_vh-set vh key val)
|
||||
(define conser
|
||||
(if (or (live-refr? key) (symbol? key))
|
||||
vhash-consq
|
||||
vhash-cons))
|
||||
(conser key val vh))
|
||||
|
||||
(define (ghash-set ghash key val)
|
||||
(define vh (ghash-vhash ghash))
|
||||
(_make-ghash (_vh-set vh key val)))
|
||||
|
||||
(define* (ghash-ref ghash key #:optional [dflt #f])
|
||||
(define vh (ghash-vhash ghash))
|
||||
(define assoc
|
||||
(if (or (live-refr? key) (symbol? key))
|
||||
vhash-assq
|
||||
vhash-assoc))
|
||||
(match (assoc key vh)
|
||||
((_k . val) val)
|
||||
(#f dflt)))
|
||||
|
||||
(define (ghash-has-key? ghash key)
|
||||
(define vh (ghash-vhash ghash))
|
||||
(define assoc
|
||||
(if (or (live-refr? key) (symbol? key))
|
||||
vhash-assq
|
||||
vhash-assoc))
|
||||
(match (assoc key vh)
|
||||
((_k . val) #t)
|
||||
(#f #f)))
|
||||
|
||||
(define (ghash-remove ghash key)
|
||||
(define vh (ghash-vhash ghash))
|
||||
(define del
|
||||
(if (or (live-refr? key) (symbol? key))
|
||||
vhash-delq
|
||||
vhash-delete))
|
||||
(_make-ghash (del key vh)))
|
||||
|
||||
(define (ghash-length ghash)
|
||||
(vlist-length (ghash-vhash ghash)))
|
||||
|
||||
(define (ghash-fold proc init ghash)
|
||||
(vhash-fold proc init (ghash-vhash ghash)))
|
||||
(define (ghash-fold-right proc init ghash)
|
||||
(vhash-fold-right proc init (ghash-vhash ghash)))
|
||||
|
||||
(define (ghash-for-each proc ghash)
|
||||
(vhash-fold
|
||||
(lambda (k v _p)
|
||||
(proc k v))
|
||||
#f
|
||||
(ghash-vhash ghash)))
|
||||
|
||||
(define (hashtable->ghash table)
|
||||
(_make-ghash
|
||||
(hashtable-fold
|
||||
(lambda (key val vh)
|
||||
(_vh-set vh key val))
|
||||
vlist-null
|
||||
table)))
|
||||
|
||||
;;; Sets
|
||||
(define-record-type <gset>
|
||||
(_make-gset ht)
|
||||
gset?
|
||||
(ht _set-ht))
|
||||
|
||||
(define (print-set set port)
|
||||
(define items
|
||||
(vhash-fold
|
||||
(lambda (k _v prev)
|
||||
(cons k prev))
|
||||
'()
|
||||
(_set-ht set)))
|
||||
(display (string-append "#<gset " items ">") port))
|
||||
|
||||
(define (make-gset . items)
|
||||
(define vh
|
||||
(fold
|
||||
(lambda (item vh)
|
||||
(define-values (add assoc)
|
||||
(if (or (live-refr? item) (symbol? item))
|
||||
(values vhash-consq vhash-assoc)
|
||||
(values vhash-cons vhash-assq)))
|
||||
;; Ensure it's unique to the set
|
||||
(if (assoc item vh)
|
||||
vh
|
||||
(add item #t vh)))
|
||||
vlist-null items))
|
||||
(_make-gset vh))
|
||||
|
||||
(define (gset-add set item)
|
||||
(define add
|
||||
(if (or (live-refr? item) (symbol? item))
|
||||
vhash-consq
|
||||
vhash-cons))
|
||||
(if (gset-member? set item)
|
||||
set
|
||||
(_make-gset (add item #t (_set-ht set)))))
|
||||
|
||||
(define (gset-remove set item)
|
||||
(define del
|
||||
(if (or (live-refr? item) (symbol? item))
|
||||
vhash-delq
|
||||
vhash-delete))
|
||||
(_make-gset (del item (_set-ht set))))
|
||||
|
||||
(define (gset-fold proc init set)
|
||||
(vhash-fold
|
||||
(lambda (key _val prev)
|
||||
(proc key prev))
|
||||
init
|
||||
(_set-ht set)))
|
||||
|
||||
(define (gset-length set)
|
||||
(vhash-fold
|
||||
(lambda (_k _v count)
|
||||
(+ count 1))
|
||||
0
|
||||
(_set-ht set)))
|
||||
|
||||
(define (gset->list set)
|
||||
(vhash-fold
|
||||
(lambda (key _val prev)
|
||||
(cons key prev))
|
||||
'()
|
||||
(_set-ht set)))
|
||||
|
||||
(define (gset-member? set key)
|
||||
(define assoc
|
||||
(if (or (live-refr? key) symbol? key)
|
||||
vhash-assq
|
||||
vhash-assoc))
|
||||
|
||||
(match (assoc key (_set-ht set))
|
||||
[(_val . #t) #t]
|
||||
[#f #f]))
|
||||
|
||||
(define (gset-for-each proc set)
|
||||
(vhash-fold
|
||||
(lambda (k v _p)
|
||||
(proc k v))
|
||||
#f
|
||||
(_set-ht set)))
|
||||
Loading…
Add table
Add a link
Reference in a new issue