R lib/tukan/module.sc => +0 -521
@@ 1,521 0,0 @@
-
-using import struct
-using import enum
-using import Option
-
-using import .libc
-using import .SHA1
-let db = (import .db)
-
-""""
- A module consists of three key-value stores mapping following types:
-
- immutable:
- Blob DB: Id (u32) -> blob (arbitrary size...)
- Hash DB: SHA-1 Hash (u160) -> Id (u32)
-
- mutable:
- Edge DB: IdId IdId (2 x u64) -> IdId (u64)
- TypeId TypeId Id u32 (4 x u32) -> TypeId Id (u64)
-
- All keys and values are aigned to 8 bytes.
-
- An Id is a integer mapping to a unique sequence of bytes. Simultaneously
- with the Id, a hash DB is filled that maps the sequence's SHA-1 value to
- an Id. Once an Id has been mapped to a blob, the mapping, and the blob itself
- must not be mutated.
-
- The same sequence of bytes will always resolve to the same Id locally within
- a module. Hashes are compatible across databases, but Ids aren't.
-
- Ids are themselves untyped, but can act as types - without a type, the blob
- contents are opaque.
-
- Edges describe directed connections from one typed Id to another using
- a typed Id as edge label, in the sense that `source @ label = target`, or
- `DB @ source @ target = value` in terms of an adjacency matrix. Edges are
- mutable, and therefore can be inserted, removed and changed freely.
-
- An Id is typed when it is paired with a second Id that acts as a type
- identifier, which is used to read the schema for the blob. The type
- identifier's blob must follow an implicit schema as well.
-
- A type identifier starts with an Id pointing to a zero-terminating string
- that uniquely and globally identifies the type kind, followed by an arbitrary
- pattern of bytes specific to that type.
-
- Two types are equivalent when their sequences point to the same kind,
- and contain the same typed ids.
-
- There are several builtin, fundamental types:
-
- untyped
- type.typename <module-uri:StringId> <name:StringId> <super-type:TypeId> <storage-type:TypeId> <memoized-value:Any> ...
- type.storage.integer <bitcount:i32> (negative bitcount: signed integer)
- type.storage.real <bitcount:u32>
- type.storage.pointer <flags:u32> <storage-class:StringId>
- type.storage.array <element-type:TypeId> <size:u64>
- type.storage.vector <element-type:TypeId> <size:u64>
- type.storage.tuple [<element-type:TypeId> ...]
- type.function <return-tuple-type:TypeId> <arguments-tuple-type:TypeId>
- type.qualify <type:TypeId> <sorted-qualifier:TypeId> ...
-
- subsequently, following builtin typenames are defined:
-
- type.typename "builtin" "Nothing" untyped (type.storage.tuple)
- type.typename "builtin" "Id" untyped (type.storage.integer 32)
- type.typename "builtin" "Type" untyped (type.storage.integer 32)
- type.typename "builtin" "Any" untyped (type.storage.tuple Type Id)
- type.typename "builtin" "String" untyped (type.storage.integer 32)
- type.typename "builtin" "Symbol" untyped (type.storage.integer 32)
-
- when a type is defined
-
-enum ModuleError
- error : Error
- database : db.Error
-
- #inline handle (self)
- fprintf (stderr) "DB error: %s\n" (mdb_strerror (storagecast self))
- abort;
-
- @@ memo
- inline __ras (T cls)
- static-if (T == db.Error)
- fn (self)
- this-type.database self
- elseif (T == Error)
- fn (self)
- this-type.error self
-
- @@ memo
- inline __as (cls T)
- static-if (T == Error)
- fn (self)
- dispatch self
- case error (err)
- copy err
- case database (err)
- err as Error
- default
- sc_error_new (repr self)
-
-let
- DB_ALIGNMENT = 8:u32
-
-fn format-hex-memory (self width)
- sz := (width + 7) // 8
- let sz2 = (sz * 2)
- local inbytes = self
- let inbytes = (bitcast &inbytes @u8)
- local str : (array i8 ((sizeof self) * 2))
- inline conv (x)
- (+ x (? (x < 10:u8) 48:u8 87:u8)) as i8
- for i in (range sz)
- c := (deref (inbytes @ i))
- i := i << 1
- str @ i = (conv ((c >> 4:u8) & 0xf:u8))
- str @ (i + 1) = (conv (c & 0xf:u8))
- string &str sz2
-
-fn format-hex-number (self width)
- sz := (width + 7) // 8
- let sz2 = (sz * 2)
- local inbytes = self
- let inbytes = (bitcast &inbytes @u8)
- local str : (array i8 ((sizeof self) * 2))
- inline conv (x)
- (+ x (? (x < 10:u8) 48:u8 87:u8)) as i8
- lasti := sz - 1
- for i in (range sz)
- ri := lasti - i
- c := (deref (inbytes @ ri))
- i := i << 1
- str @ i = (conv ((c >> 4:u8) & 0xf:u8))
- str @ (i + 1) = (conv (c & 0xf:u8))
- string &str sz2
-
-inline align-size (offset align)
- (offset + align - 1) & (~ (align - 1))
-
-type Id : u32
- let None = (nullof this-type)
-
- inline... wrap
- case (value : u32,)
- bitcast value this-type
- case (value : u64,)
- itrunc value this-type
-
- let __== = integer.__==
-
-
- fn __repr (self)
- .. (tostring (storagecast self)) ":?"
-
- @@ memo
- inline __as (self T)
- static-if (T == bool)
- let ST = (storageof this-type)
- let nullval = (nullof ST)
- inline (self)
- (storagecast self) != nullval
-
-struct TypedId plain
- value : Id = Id.None
- type : Id = Id.None
-
- fn __repr (self)
- .. (tostring (storagecast self.value))
- \ ":" (tostring (storagecast self.type))
-
-static-assert ((sizeof TypedId) == 8)
-
-struct Edge plain
- tail : TypedId
- key : TypedId
- head : TypedId
-
- fn __repr (self)
- .. "<" (repr self.tail) " @ " (repr self.key) " = " (repr self.head) ">"
-
-static-assert ((sizeof Edge) == 24)
-
-type Digest
- \ < integer : (integer 192) # only 160 bits are active, the rest is null
- #\ < array : (array u64 3)
- fn __repr (self)
- local value = (storagecast self)
- .. "<digest "
- format-hex-number value ((sizeof SHA1.DigestType) * 8)
- #format-hex-number value ((sizeof this-type) * 8)
- ">"
-
-static-assert ((sizeof Digest) == 24)
-
-""""type.typename <uri:StringId> <name:StringId> <super-type:TypeId> <storage-type:TypeId> <memoized-value:Any> ...
- type.storage.integer <bitcount:i32> (negative bitcount: signed integer)
- type.storage.real <bitcount:u32>
- type.storage.pointer <flags:u32> <storage-class:StringId>
- type.storage.array <element-type:TypeId> <size:u64>
- type.storage.vector <element-type:TypeId> <size:u64>
- type.storage.tuple [<element-type:TypeId> ...]
- type.function <return-tuple-type:TypeId> <arguments-tuple-type:TypeId>
- type.qualify <type:TypeId> <sorted-qualifier:TypeId> ...
-
-let StringId = Id
-let TypeId = Id
-
-struct TypeHeader plain
- # string
- kind : StringId
-
-struct TypenameType plain
- Kind := "type.typename"
-
- header : TypeHeader
- uri : StringId
- name : StringId
- super : StringId
- storage : StringId
- values : (array TypedId)
-
-struct IntegerType plain
- Kind := "type.storage.integer"
-
- header : TypeHeader
- bitcount : i32
-
-struct RealType plain
- Kind := "type.storage.real"
-
- header : TypeHeader
- bitcount : u32
-struct PointerType plain
- Kind := "type.storage.pointer"
-
- header : TypeHeader
- flags : u32
- storage : StringId
-struct ArrayType plain
- Kind := "type.storage.array"
-
- header : TypeHeader
- element : TypeId
- size : u64
-struct VectorType plain
- Kind := "type.storage.vector"
-
- header : TypeHeader
- element : TypeId
- size : u64
-struct TupleType plain
- Kind := "type.storage.tuple"
-
- header : TypeHeader
- elements : (array TypeId)
-struct FunctionType plain
- Kind := "type.function"
-
- header : TypeHeader
- returns : TypeId
- params : TypeId
-struct QualifyType plain
- Kind := "type.qualify"
-
- header : TypeHeader
- type : TypeId
- qualifiers : (array TypeId)
-
-let
- DBI_BLOB = "blob"
- DBI_HASH = "hash"
- DBI_EDGE = "edge"
-
- MAX_DBS = 4
-
-struct Databases plain
- blob : db.Index
- hash : db.Index
- edge : db.Index
-
-type Act < Struct
-
-struct ViewAct < Act
- _txn : db.Transaction
- _db : Databases
-
- inline __typecall (cls txn db)
- super-type.__typecall cls
- _txn = txn
- _db = db
-
- inline __drop (self)
- 'abort self._txn
-
- inline abort (self)
- 'abort self._txn
- lose self
-
- inline commit (self)
- 'abort self._txn
- lose self
-
-struct EditAct < Act
- _txn : db.Transaction
- _db : Databases
-
- inline __typecall (cls txn db)
- super-type.__typecall cls
- _txn = txn
- _db = db
-
- inline __drop (self)
- 'abort self._txn
-
- inline abort (self)
- 'abort self._txn
- lose self
-
- inline commit (self)
- try
- 'commit self._txn
- except (err)
- raise (err as ModuleError)
- lose self
-
-struct Module
- _env : db.Environment
- _db : Databases
-
- fn from-path (path)
- let env =
- try (db.Environment)
- except (err)
- raise (err as ModuleError)
- try
- 'set-maxdbs env MAX_DBS
- 'open env path db.NoSubDir
- let txn = ('begin env)
- try
- let dbi_blob =
- 'open txn DBI_BLOB db.Create
- let dbi_hash =
- 'open txn DBI_HASH db.Create
- let dbi_edge =
- 'open txn DBI_EDGE db.Create
- 'commit txn
- return
- super-type.__typecall this-type
- _env = env
- _db =
- Databases
- blob = dbi_blob
- hash = dbi_hash
- edge = dbi_edge
- except (err)
- 'abort txn
- raise err
- except (err)
- 'close env
- raise (err as ModuleError)
-
- inline __typecall (cls path)
- from-path path
-
- inline view (self)
- let txn =
- try ('begin self._env db.ReadOnly)
- except (err) (raise (err as ModuleError))
- ViewAct txn self._db
-
- inline edit (self)
- let txn =
- try ('begin self._env)
- except (err) (raise (err as ModuleError))
- EditAct txn self._db
-
- inline __drop (self)
- 'close self._env
-
-inline static-type (...)
- inline (f)
- static-typify f ...
-
-fn hash-data (sz data)
- local sha : SHA1
- 'hash sha (bitcast data rawstring) (sz as u32)
- local digest = (nullof Digest)
- let digest20 = (@ (bitcast &digest (mutable @SHA1.DigestType)))
- 'digest sha digest20
- digest
-
-struct Blob plain
- size : usize
- data : voidstar
- digest : Digest
-
- inline... __typecall
- case (cls, size : usize, data : voidstar)
- super-type.__typecall cls size data (hash-data size data)
- case (cls, str : string)
- this-function cls (countof str) (str as rawstring)
- case (cls, value)
- local tmp = value
- this-function cls (sizeof value) &value
-
-type+ Act
- fn... id-from-digest-key (act, key : db.Value)
- try
- # if this passes, it already exists
- deref (('get act._txn act._db.hash key) as u64)
- except (err)
- if (err == db.NotFound)
- 0:u64
- else
- raise (err as ModuleError)
-
- fn... digest-id (act, digest : Digest)
- Id.wrap (id-from-digest-key act (digest as db.Value))
-
- fn... load-edge (act, edge : Edge)
- local edge = edge
- let key = (db.Value ((sizeof TypedId) * 2) &edge.tail)
- let content =
- try ('get act._txn act._db.edge key)
- except (err) (raise (err as ModuleError))
- let contentsz source = (unpack content)
- assert (contentsz == (sizeof TypedId))
- source := (bitcast source @TypedId)
- return (deref @source)
-
- fn... load-blob (act, id : Id)
- id := (imply (storagecast id) u64)
- let content =
- try ('get act._txn act._db.blob (id as db.Value))
- except (err) (raise (err as ModuleError))
- let contentsz source = (unpack content)
- source := (bitcast source (mutable @u64))
- sz := @source
- source := (& (source @ 1))
- source := (bitcast source (mutable rawstring))
- Blob sz source
-
-type+ EditAct
- fn... store-edge (act, edge : Edge)
- local edge = edge
- let key = (db.Value ((sizeof TypedId) * 2) &edge.tail)
- let value = (db.Value (sizeof TypedId) &edge.head)
- try ('put act._txn act._db.edge key value)
- except (err) (raise (err as ModuleError))
- return;
-
- fn... store-blob (act, blob : Blob)
- let sz = blob.size
- let data = blob.data
- key := blob.digest as db.Value
- let id = ('id-from-digest-key act key)
- if (id != 0:u64)
- return (Id.wrap id)
- try
- # need to commit a new chunk
- let cur = (db.Cursor act._txn act._db.hash)
- defer (inline () ('close cur))
- try
- # it's possible someone else has since added this blob
- let k v = ('get cur key db.SetKey)
- id := (deref (v as u64))
- return (Id.wrap id)
- except (err)
- if (err != db.NotFound)
- raise err
- # they have not - do the hard work now
- # step 1: allocate a new id
- let blob_cur = (db.Cursor act._txn act._db.blob)
- defer (inline () ('close blob_cur))
- term_id := -1:u64 as db.Value
- let highest_id =
- try
- 'get blob_cur term_id db.SetRange
- let k v = ('get blob_cur db.Prev)
- deref (k as u64)
- except (err)
- if (err != db.NotFound)
- raise err
- 'put blob_cur term_id (db.Value)
- 0:u64
- id := (highest_id + 1)
- let id_key = (db.Value id)
- do
- # step 2: map id to content, map hash to id
- the first qword of content is its actual size
- every blob is zero terminated
- let alignedsz = (align-size (sz + 1) DB_ALIGNMENT)
- local content = (db.Value (alignedsz + (sizeof u64)) null)
- 'put blob_cur id_key content db.Reserve
- let targetsize target = (unpack content)
- target := (bitcast target (mutable @u64))
- @target = sz
- target := (& (target @ 1))
- target := (bitcast target (mutable rawstring))
- assert ((ptrtoint target usize) % DB_ALIGNMENT == 0)
- memcpy target data sz
- memset (& (target @ sz)) 0 (alignedsz - sz)
- 'put act._txn act._db.hash key id_key
- return (Id.wrap id)
- except (err)
- raise (err as ModuleError)
-
-type+ Blob
-
- inline __== (cls T)
- static-if (cls == T)
- inline (self other)
- self.digest == other.digest
-
-
-
-do
- let Module Blob Edge TypedId Id ModuleError
-
- locals;
A => lib/tukan/pickle.sc +197 -0
@@ 0,0 1,197 @@
+using import Map
+using import Set
+using import String
+
+using import .uvm
+
+# Serialization
+################################################################################
+
+let filewriter =
+ inline (data size file lut lutsize)
+ let ok? =
+ 'write file data size
+ assert ok? "write failed"
+
+let hashfilewriter =
+ inline (data size file lut lutsize)
+ let ok? =
+ do
+ assert (size == (sizeof Atom.DigestType))
+ let key = (@ (bitcast data @Atom.IntDigestType))
+ local index : u32 =
+ do
+ try (copy ('get lut key))
+ else
+ report "filewriter: LUT lookup error: " key
+ 0:u32
+ 'write file &index (sizeof index)
+ assert ok? "hash write failed"
+
+let filereader =
+ inline (data size file lut lutsize)
+ let ok? =
+ 'read file data size
+ assert ok? "read failed"
+
+let hashfilereader =
+ inline (data size file lut lutsize)
+ let ok? =
+ do
+ assert (size == (sizeof Atom.DigestType))
+ local index : u32
+ let ok? = ('read file &index (sizeof index))
+ try
+ (@ (bitcast data (mutable @Atom.IntDigestType))) = ('get lut index)
+ ok?
+ else
+ report "filereader: LUT lookup error"
+ false
+ assert ok? "hash read failed"
+
+fn... pickle1 (file, lut, lutsize, value : Atom)
+ #local digest : SHA256.DigestType = ('uhash value)
+ #hashfilewriter (&digest as rawstring) (sizeof digest) file lut lutsize true
+ local kind : u8 = (('kind value) as integer as u8)
+ filewriter &kind (sizeof kind) file lut lutsize
+
+ inline pickle-str (str)
+ let sz = (countof str)
+ local size : u64 = sz
+ filewriter (&size as rawstring) (sizeof size) file lut lutsize
+ filewriter (str as rawstring) sz file lut lutsize
+
+ dispatch value
+ case Number (num)
+ (Number.writer filewriter) num file lut lutsize
+ case String (str)
+ pickle-str str
+ case Symbol (str)
+ pickle-str str
+ case TableLimb (limb)
+ (TableLimb.writer filewriter hashfilewriter) limb file lut lutsize
+ case Table (table)
+ (Table.writer filewriter hashfilewriter) table file lut lutsize
+ default;
+
+fn unpickle1 (file lut lutsize cache)
+ #local digest : SHA256.DigestType
+ #hashfilereader (&digest as rawstring) (sizeof digest) file lut lutsize true
+ local kind : u8
+ filereader &kind (sizeof kind) file lut lutsize
+
+ inline unpickle-str ()
+ local size : u64
+ filereader (&size as rawstring) (sizeof size) file lut lutsize
+ let sz = (deref size)
+ local str = (String sz)
+ 'resize str sz
+ filereader (str as rawstring) sz file lut lutsize
+ str
+
+ #let kind = (Atom.kind-from-digest digest)
+ let kind = (kind as i32 as Atom.Kind)
+ let atom =
+ switch kind
+ case Atom.Kind.None (Atom)
+ case Atom.Kind.False (Atom false)
+ case Atom.Kind.True (Atom true)
+ case Atom.Kind.Number
+ local num = ((Number.reader filereader) file lut lutsize)
+ Atom num
+ case Atom.Kind.String
+ Atom (unpickle-str)
+ case Atom.Kind.Symbol
+ Atom.wrap (UString (unpickle-str)) kind
+ case Atom.Kind.TableLimb
+ Atom ((TableLimb.reader filereader hashfilereader) cache file lut lutsize)
+ case Atom.Kind.Table
+ Atom ((Table.reader filereader hashfilereader) cache file lut lutsize)
+ default
+ assert false "unhandled atom kind"
+ unreachable;
+ #assert (atom == digest)
+ atom
+
+fn... pickle (file, root : Atom)
+ local done : (Set Atom)
+ local lutsize : u32 = 0
+ local lut : (Map Atom.IntDigestType u32)
+ va-map
+ inline (value)
+ local key = ('hashbits value)
+ #report "preset LUT:" key lutsize
+ 'set lut key lutsize
+ lutsize += 1
+ 'insert done value
+ Atom;
+ Atom false
+ Atom true
+ fn recur (value ...)
+ let file done lut lutsize = ...
+ let recur = this-function
+ if ('in? done value)
+ return;
+ 'insert done (copy value)
+ assert ('in? done value)
+ dispatch value
+ case TableLimb (limb)
+ for value in limb.cells
+ recur value ...
+ case Table (table)
+ recur table.meta ...
+ recur table.ivalues ...
+ recur table.keys ...
+ recur table.values ...
+ default;
+ #report "pickling" ('tostring value)
+ pickle1 file lut lutsize value
+ local key = ('hashbits value)
+ #report "set LUT:" key lutsize
+ 'set lut key lutsize
+ lutsize += 1
+ ;
+ recur root file done lut lutsize
+
+fn unpickle (file)
+ let cur = ('tell file)
+ 'seek file (end = 0)
+ let size = ('tell file)
+ 'seek file cur
+ local cache :
+ Set Atom
+ inline (value)
+ static-if ((typeof value) == Atom.DigestType)
+ Atom.hash-from-digest value
+ else
+ hash value
+ local lut : (Map u32 Atom.IntDigestType)
+ local lutsize : u32
+ va-map
+ inline (value)
+ local key = ('hashbits value)
+ #report "preset LUT:" key lutsize
+ 'set lut lutsize key
+ lutsize += 1
+ 'insert cache value
+ Atom;
+ Atom false
+ Atom true
+ loop (root = (unpickle1 file lut lutsize cache))
+ local key = ('hashbits root)
+ #report "set LUT:" key lutsize
+ 'set lut lutsize key
+ lutsize += 1
+ #report "unpickled" ('tostring root)
+ 'insert cache (copy root)
+ if (('tell file) >= size)
+ break root
+ let atom = (unpickle1 file lut lutsize cache)
+ atom
+
+###############################################################################
+
+do
+ let pickle unpickle
+
+ locals;
R lib/tukan/ustore.sc => +0 -189
@@ 1,189 0,0 @@
-""""UStore
- ======
-
- The UStore module provides the memory interface to Tukan. At the fundamental
- level it can be used to store and retrieve information to/from the universe.
-
-using import struct
-using import enum
-using import Map
-using import Array
-using import .SHA256
-
-# declare void @llvm.memcpy.p0i8.p0i8.i64(i8* <dest>, i8* <src>,
- i64 <len>, i1 <isvolatile>)
-let llvm.memcpy.p0i8.p0i8.i64 =
- extern 'llvm.memcpy.p0i8.p0i8.i64
- function void (mutable rawstring) rawstring i64 bool
-
-enum UError
- SegmentationFault
-
-enum URefKind : u32
- Unknown = 0
- String = 1 # utf-8 string
- Symbol = 2 # utf-8 string
- Number = 3 # sign, expn, len, bits...
- Table = 4
- TableLimb = 5
- Tuple = 6
-
-struct URef plain
- Hasher := SHA224
- DigestType := Hasher.DigestType
- Kind := URefKind
-
- address : (array u32 7) =
- arrayof u32
- 0x8c024ad1:u32
- 0xc92b3a2a:u32
- 0xbb026147:u32
- 0xc4348228:u32
- 0x1fb0a215:u32
- 0x2aa68e82:u32
- 0x2fe4b3c5:u32
- kind : URefKind = URefKind.Unknown
-
- fn null? (self)
- self == (this-type)
-
- fn... set (self, data : voidstar, size : usize)
- cls := (typeof self)
- local sha : Hasher
- 'hash sha (data as rawstring) size
- 'digest sha (@ (bitcast (& self.address) (mutable @DigestType)))
- ;
-
- inline... to (cls, data : voidstar, size : usize)
- local self : cls
- set self data size
- self
-
- inline __== (cls T)
- static-if (cls == T)
- fn (self other)
- and
- self.kind == other.kind
- self.address == other.address
-
- inline __as (cls T)
- static-if (T == integer)
- fn (self)
- let self =
- static-if (&? self) self
- else
- local self = self
- @ (bitcast (& self.address) (pointer (integer 224)))
-
- fn __repr (self)
- values := self.address
- .. "(URef "
- ..
- va-map
- inline (i)
- value := values @ i
- ..
- va-map
- inline (k)
- #k := 3 - k
- let e1 e0 =
- ((value >> (k * 8)) as u8) & 0xf
- ((value >> (k * 8 + 4)) as u8) & 0xf
- ..
- hex e0
- hex e1
- va-range 4
- va-range 7
- " "
- repr self.kind
- ")"
-
-run-stage;
-
-struct UMemory plain
- ptr : voidstar
- size : usize
-
- @@ memo
- inline __rimply (T cls)
- static-if (T == string)
- inline (self)
- cls (self as rawstring) (countof self)
-
- @@ memo
- inline __as (T cls)
- static-if (cls == string)
- inline (self)
- string (self.ptr as rawstring) self.size
-
- fn __repr (self)
- .. "<UMemory @"
- hex (ptrtoint self.ptr usize)
- ":u8x"
- dec self.size
- ">"
-
-fn hasher (addr)
- bor
- imply (addr @ 0) u64
- (imply (addr @ 1) u64) << 32
-
-struct UStore # content addressable store abstraction
- WordType := u64
- WordTypeSize := (sizeof WordType)
-
- # address to offset into memory
- map : (Map URef.DigestType UMemory hasher)
-
- fn... store (self : &this-type, mem : UMemory)
- let data size = mem.ptr mem.size
- let addr = ('to URef data size)
- try
- 'get self.map addr.address
- ;
- else
- numblocks := ((size + WordTypeSize - 1) // WordTypeSize)
- let ptr = (malloc-array WordType numblocks)
- #'append-slots self.memory numblocks
- #'emplace-append-many self.memory numblocks 0xdeadbeef:u64
- for i in (range numblocks)
- ptr @ i = 0xdeadbeefedc0ffee:u64
- #ptr := (& (self.memory @ offset))
- llvm.memcpy.p0i8.p0i8.i64
- ptr as (mutable rawstring)
- data as rawstring
- size as i64
- false
- 'set self.map addr.address
- UMemory
- ptr = ptr
- size = size
- addr
-
- fn... load (self : &this-type, addr : URef)
- try
- 'get self.map addr.address
- else
- raise (UError.SegmentationFault)
-
-global g_ustore : UStore
-'store g_ustore (UMemory null 0)
-
-type+ URef
- fn load (self)
- let T = (typeof self)
- let mem = ('load g_ustore self)
- _ mem.ptr mem.size
-
- inline... store (ptr : voidstar, size : usize)
- 'store g_ustore (UMemory ptr size)
-
-static-if main-module?
- try
- print ('load (URef))
- else
- print "failed"
-
-do
- let UMemory URef UError
- locals;
No newline at end of file
A => lib/tukan/uvm.sc +1391 -0
@@ 0,0 1,1391 @@
+using import struct
+using import enum
+using import Map
+using import Set
+using import Array
+using import String
+using import Rc
+
+using import .libbf
+using import .thread
+using import .SHA256
+
+# features:
+ * six value types: none, bool, number, string (text?), symbol, cell
+ * a pure functional evaluator without mutation, recursion or other side effects
+ * GC free, refcount based memory management
+ * any value can be used as a key in a map
+ * simple file serialization
+ * LMDB integration
+
+let u256 = (integer 256)
+
+###############################################################################
+
+inline verify-sizeof (size)
+ inline (T)
+ #static-assert ((alignof T) == 8)
+ .. "(alignof " (tostring T) ") != 8"
+ static-assert ((sizeof T) == size)
+ .. "(sizeof " (tostring T) ") == "
+ \ (tostring (sizeof T)) " != " (tostring size)
+ T
+
+# Number
+###############################################################################
+
+let realloc =
+ extern 'realloc
+ function voidstar voidstar usize
+fn urealloc (opaque ptr size)
+ realloc ptr size
+
+struct NumberContext
+ ctx : bf_context_t
+
+ inline __typecall (cls)
+ local self =
+ super-type.__typecall cls
+ bf_context_init &self.ctx urealloc null
+ self
+
+ fn __drop (self)
+ bf_context_end &self.ctx
+ ;
+
+global _number_context =
+ LocalStorage
+ fn () (NumberContext)
+inline bfcontext ()
+ & ((@ _number_context) . ctx)
+unlet _number_context
+
+type Number :: (storageof bf_t)
+
+ let DEFAULT_PREC = 56
+ let CType = @bf_t
+ let MutableCType = (mutable @bf_t)
+
+ inline... set
+ case (self)
+ bf_set_zero self 0
+ case (self, value : Nothing)
+ case (self, value : i64)
+ bf_set_si self value
+ case (self, value : u64)
+ bf_set_ui self value
+ case (self, value : integer)
+ bf_set_si self value
+ case (self, value : real)
+ bf_set_float64 self value
+ case (self, value : &bf_t)
+ bf_set self &value
+ case (self, value : this-type)
+ bf_set self value
+
+ inline __typecall (cls ...)
+ local self : bf_t
+ bf_init (bfcontext) &self
+ let self = (bitcast self cls)
+ set self ...
+ self
+
+ @@ memo
+ inline writer (f)
+ fn write (self ...)
+ viewing self
+ let index =
+ try ('toindex32 self)
+ else
+ let self = (bitcast self bf_t)
+ va-map
+ inline (name)
+ let member = (getattr self name)
+ f (&member as rawstring) (sizeof member) ...
+ \ 'sign 'expn 'len
+ f (self.tab as rawstring) ((sizeof (self.tab @ 0)) * self.len) ...
+ return;
+ local index : i32 = (- (index as i32))
+ f (&index as rawstring) (sizeof index) ...
+ ;
+
+ @@ memo
+ inline reader (f)
+ fn read (...)
+ local index : i32
+ f (&index as rawstring) (sizeof index) ...
+ if (index < 0)
+ return (this-type -index)
+ local source : bf_t
+ source.sign = index
+ va-map
+ inline (name)
+ let member = (getattr source name)
+ f (&member as rawstring) (sizeof member) ...
+ \ 'expn 'len
+ let limbT = (typeof (source.tab @ 0))
+ source.tab = (alloca-array limbT source.len)
+ f (source.tab as rawstring) ((sizeof limbT) * source.len) ...
+ this-type source
+
+ let sha-writer =
+ writer
+ inline (data size sha)
+ 'hash sha data size
+
+ fn uhash (self)
+ viewing self
+ local digest : SHA256.DigestType
+ local sha : SHA256
+ sha-writer self sha
+ 'digest sha digest
+ digest
+
+ fn __drop (self)
+ let self =
+ static-if (&? self) self
+ else (local self = self)
+ bf_delete self
+
+ inline __copy (self)
+ this-type self
+
+ fn toi32 (self)
+ local outp : i32
+ bf_get_int32 &outp self 0
+ outp
+ fn toi64 (self)
+ local outp : i64
+ bf_get_int64 &outp self 0
+ outp
+ fn tof64 (self)
+ local outp : f64
+ bf_get_float64 self &outp bf_rnd_t.BF_RNDN
+ outp
+
+ fn toindex32 (self)
+ if (self >= 0)
+ if (self <= 0x7fffffff:i32)
+ if (('floor self) == self)
+ return ((toi32 self) as u32)
+ raise;
+
+ fn toindex (self)
+ if (self >= 0)
+ if (self <= 0x7fffffffffffffff:i64)
+ if (('floor self) == self)
+ return ((toi64 self) as u64)
+ raise;
+
+ @@ memo
+ inline __as (cls T)
+ static-match T
+ case integer toi32
+ case i32 toi32
+ case i64 toi64
+ case real tof64
+ case f64 tof64
+ default;
+
+ unlet toi32 toi64 tof64
+
+ @@ memo
+ inline __imply (cls T)
+ static-if ((&? cls) and ((T == CType) or (T == MutableCType)))
+ inline (self) (& (bitcast (view self) bf_t))
+
+ @@ memo
+ inline __rimply (T cls)
+ static-if ((T < integer) or (T < real))
+ inline (self)
+ cls self
+
+ fn tostring (self)
+ local sz : u64
+ let s =
+ bf_ftoa &sz self 10 DEFAULT_PREC BF_FTOA_FORMAT_FREE_MIN
+ String s sz
+
+ fn __repr (self)
+ (tostring self) as string
+
+ fn cmp (self other)
+ bf_cmp self other
+
+ inline cmpfn (op)
+ @@ memo
+ inline (cls T)
+ static-if (cls == T)
+ inline (a b) (op (cmp a b) 0)
+
+ inline op0ifn (f ...)
+ inline (self)
+ let result = (this-type self)
+ f result ...
+ result
+
+ inline op1fn (f ...)
+ inline (self)
+ let result = (this-type none)
+ f result self ...
+ result
+
+ inline op2fn (f ...)
+ @@ memo
+ inline (cls T)
+ static-if (cls == T)
+ inline (a b)
+ let result = (this-type none)
+ f result (view a) (view b) ...
+ result
+
+ inline op2r2fn (f ...)
+ @@ memo
+ inline (cls T)
+ static-if (cls == T)
+ inline (a b)
+ let result1 = (this-type none)
+ let result2 = (this-type none)
+ f result1 result2 (view a) (view b) ...
+ result1
+
+ let
+ __== = (cmpfn ==)
+ __!= = (cmpfn !=)
+ __>= = (cmpfn >=)
+ __<= = (cmpfn <=)
+ __> = (cmpfn >)
+ __< = (cmpfn <)
+
+ let
+ __+ = (op2fn bf_add DEFAULT_PREC 0)
+ __- = (op2fn bf_sub DEFAULT_PREC 0)
+ __* = (op2fn bf_mul DEFAULT_PREC 0)
+ __/ = (op2fn bf_div DEFAULT_PREC 0)
+ __// = (op2r2fn bf_divrem DEFAULT_PREC 0 bf_rnd_t.BF_RNDZ)
+ __% = (op2fn bf_rem DEFAULT_PREC 0 bf_rnd_t.BF_RNDZ)
+
+ __** = (op2fn bf_pow DEFAULT_PREC 0)
+ atan2 = (op2fn bf_atan2 DEFAULT_PREC 0)
+
+ __| = (op2fn bf_logic_or)
+ __^ = (op2fn bf_logic_xor)
+ __& = (op2fn bf_logic_and)
+
+ let __neg = (op0ifn bf_neg)
+
+ let
+ sqrt = (op1fn bf_sqrt DEFAULT_PREC 0)
+ exp = (op1fn bf_exp DEFAULT_PREC 0)
+ log = (op1fn bf_log DEFAULT_PREC 0)
+ cos = (op1fn bf_cos DEFAULT_PREC 0)
+ sin = (op1fn bf_sin DEFAULT_PREC 0)
+ tan = (op1fn bf_tan DEFAULT_PREC 0)
+ atan = (op1fn bf_atan DEFAULT_PREC 0)
+ asin = (op1fn bf_asin DEFAULT_PREC 0)
+ acos = (op1fn bf_acos DEFAULT_PREC 0)
+
+ floor = (op0ifn bf_rint bf_rnd_t.BF_RNDZ)
+ round = (op0ifn bf_rint bf_rnd_t.BF_RNDN)
+
+ unlet cmpfn op2fn op0ifn op1fn
+
+################################################################################
+
+type Atom :: voidstar
+ let Hasher = SHA256
+ let DigestType = Hasher.DigestType
+ let IntDigestType = u256
+
+# Table
+################################################################################
+
+let IndexBits = 4
+let ArrayCellCount = (1 << IndexBits)
+let IndexMask = (ArrayCellCount - 1)
+let CellIndexType = u16
+
+fn depth-maxindex (depth)
+ ((ArrayCellCount as u64) << (depth * IndexBits)) - 1
+
+@@ verify-sizeof 136
+struct TableLimb
+ cells : (array Atom ArrayCellCount)
+ mask : u64 = 0 # slots used
+
+ @@ memo
+ inline writer (f hashf)
+ fn write (self ...)
+ viewing self
+ local mask : CellIndexType = (self.mask as CellIndexType)
+ f (&mask as rawstring) (sizeof mask) ...
+ local celldigest : SHA256.DigestType
+ inline handle-cell (i)
+ if ((mask & (1 << i)) != 0)
+ celldigest = ('uhash (self.cells @ i))
+ hashf (&celldigest as rawstring) (sizeof celldigest) ...
+ static-if (&? self)
+ for i in (range ArrayCellCount) (handle-cell i)
+ else
+ va-map handle-cell (va-range ArrayCellCount)
+
+ @@ memo
+ inline reader (f hashf)
+ fn read (cache ...)
+ local limb : this-type
+ local mask : CellIndexType
+ f (&mask as rawstring) (sizeof mask) ...
+ limb.mask = mask
+ local celldigest : SHA256.DigestType
+ for i in (range ArrayCellCount)
+ if ((limb.mask & (1 << i)) != 0)
+ hashf (&celldigest as rawstring) (sizeof celldigest) ...
+ limb.cells @ i =
+ do
+ try
+ copy
+ 'get cache celldigest
+ else
+ report "TableLimb cell missing:"
+ sha256-digest-string celldigest
+ \ "(" (Atom.kind-from-digest celldigest) ")"
+ Atom;
+ limb
+
+ let sha-writer =
+ writer
+ inline (data size sha)
+ 'hash sha data size
+ inline (data size sha)
+ 'hash sha data size
+
+ fn uhash (self)
+ viewing self
+ local digest : SHA256.DigestType
+ local sha : SHA256
+ sha-writer self sha
+ 'digest sha digest
+ digest
+
+ fn __copy (self)
+ viewing self
+ super-type.__typecall this-type
+ cells = (typeinit (va-map copy (unpack self.cells)))
+ mask = self.mask
+
+ fn __repr (self) "<TableLimb>"
+
+@@ verify-sizeof 40
+struct Table
+ meta : Atom
+ keys : Atom
+ values : Atom
+ ivalues : Atom
+ depth : u64
+
+ fn __copy (self)
+ viewing self
+ super-type.__typecall this-type
+ meta = (copy self.meta)
+ keys = (copy self.keys)
+ values = (copy self.values)
+ ivalues = (copy self.ivalues)
+ depth = self.depth
+
+ @@ memo
+ inline writer (f hashf)
+ fn write (self ...)
+ viewing self
+ local memberdigest : SHA256.DigestType
+ va-map
+ inline (name)
+ let member = (getattr self name)
+ memberdigest = ('uhash member)
+ hashf (&memberdigest as rawstring) (sizeof memberdigest) ...
+ \ 'meta 'keys 'values 'ivalues
+ local depth = self.depth
+ f (&depth as rawstring) (sizeof depth) ...
+
+ @@ memo
+ inline reader (f hashf)
+ fn read (cache ...)
+ returning (uniqueof this-type -1)
+ local memberdigest : SHA256.DigestType
+ local table : this-type
+ va-map
+ inline (name)
+ let member = (getattr table name)
+ hashf (&memberdigest as rawstring) (sizeof memberdigest) ...
+ member =
+ do
+ try
+ copy
+ 'get cache memberdigest
+ else
+ report "Table member missing"
+ sha256-digest-string memberdigest
+ \ "(" (Atom.kind-from-digest memberdigest) ")"
+ Atom;
+ \ 'meta 'keys 'values 'ivalues
+ f (&table.depth as rawstring) (sizeof table.depth) ...
+ table
+
+ let sha-writer =
+ writer
+ inline (data size sha)
+ 'hash sha data size
+ inline (data size sha)
+ 'hash sha data size
+
+ fn uhash (self)
+ viewing self
+ local digest : SHA256.DigestType
+ local sha : SHA256
+ sha-writer self sha
+ 'digest sha digest
+ digest
+
+ @@ memo
+ inline gen-each-index (f)
+ fn process (table ...)
+ fn recur (node depth index ...)
+ returning void
+ dispatch node
+ case TableLimb (limb)
+ let maxindex = (depth-maxindex depth)
+ let slot-capacity = ((maxindex >> IndexBits) + 1)
+ for i in (range ArrayCellCount)
+ let index = (index + slot-capacity * i)
+ this-function
+ limb.cells @ i
+ depth - 1
+ index
+ ...
+ case None ()
+ default
+ f index node ...
+ recur table.ivalues table.depth 0:u64 ...
+
+ @@ memo
+ inline gen-each-pair (f)
+ fn process (table ...)
+ fn recur (key value ...)
+ returning void
+ dispatch key
+ case TableLimb (klimb)
+ dispatch value
+ case TableLimb (vlimb)
+ let kl = klimb.cells
+ let vl = vlimb.cells
+ for i in (range ArrayCellCount)
+ let k v =
+ kl @ i
+ vl @ i
+ this-function k v ...
+ default
+ assert false "table structure: internal error"
+ unreachable;
+ case None ()
+ default
+ f key value ...
+ recur table.keys table.values ...
+
+ fn __repr (self) "<Table>"
+
+ fn capacity (self)
+ depth-maxindex (copy self.depth)
+
+ fn... set-index (self, index : u64, value : Atom)
+ let value = (move value)
+
+ fn recur (node depth index value)
+ returning (uniqueof Atom -1) u64
+ #raising (uniqueof UError -1)
+
+ if (index == 0)
+ # truncate
+ return value depth
+
+ node := (copy node)
+ maxindex := (depth-maxindex depth)
+ let node depth =
+ if (index > maxindex)
+ # exceeding existing capacity
+ if ('none? value)
+ # nothing to do
+ return node depth
+ if ('none? node)
+ # increase depth until it fits
+ _ node
+ loop (depth = depth)
+ let newdepth = (depth + 1)
+ maxindex := (depth-maxindex newdepth)
+ if (index > maxindex)
+ repeat newdepth
+ else
+ break newdepth
+ else
+ loop (node depth = (copy node) depth)
+ let newdepth = (depth + 1)
+ maxindex := (depth-maxindex newdepth)
+ # split
+ local newlimb = (TableLimb)
+ newlimb.mask = 1
+ newlimb.cells @ 0 = node
+ for i in (range 1 ArrayCellCount)
+ newlimb.cells @ i = (Atom)
+ let node = (Atom newlimb)
+ if (index > maxindex)
+ repeat node newdepth
+ else
+ break node newdepth
+ else
+ _ node depth
+
+ let newlimb =
+ dispatch node
+ case TableLimb (limb)
+ local newlimb = (copy limb)
+ default
+ # split
+ local newlimb : TableLimb
+ if (not ('none? node))
+ newlimb.mask = 1
+ newlimb.cells @ 0 = node
+ for i in (range 1 ArrayCellCount)
+ newlimb.cells @ i = (Atom)
+ newlimb
+
+ maxindex := (depth-maxindex depth)
+ let slot-capacity = ((maxindex >> IndexBits) + 1)
+ let slot-index = (index // slot-capacity)
+ assert (slot-index < ArrayCellCount)
+
+ # subindex
+ let index = (index - (slot-index * slot-capacity))
+ let value newdepth =
+ if (depth == 0)
+ _ (copy value) depth
+ else
+ let value depth =
+ this-function (newlimb.cells @ slot-index) (depth - 1) index value
+ _ value (depth + 1)
+ flag := 1:u64 << slot-index
+ if ('none? value)
+ newlimb.mask &= (~ flag)
+ else
+ newlimb.mask |= flag
+ if (newlimb.mask == 0) # empty
+ return (Atom) depth
+ else
+ newlimb.cells @ slot-index = value
+ return
+ Atom newlimb
+ newdepth
+ # truncate excess capacity
+ let node depth =
+ loop (node depth = (recur self.ivalues (copy self.depth) index value))
+ dispatch node
+ case TableLimb (limb)
+ if (limb.mask == 1)
+ repeat
+ copy (limb.cells @ 0)
+ depth - 1
+ default;
+ break node depth
+ local self = (copy self)
+ self.ivalues = node
+ self.depth = depth
+ self
+
+ fn... del-index (self, index : u64)
+ set-index self index (Atom)
+
+ fn... get-index (self, index : u64)
+ fn recur (node depth index)
+ returning (uniqueof Atom -1)
+ #raising (uniqueof UError -1)
+
+ node := (copy node)
+
+ maxindex := (depth-maxindex depth)
+ if (index > maxindex)
+ return (Atom)
+
+ dispatch node
+ case TableLimb (limb)
+ let slot-capacity = ((maxindex >> IndexBits) + 1)
+ let slot-index = (index // slot-capacity)
+ assert (slot-index < ArrayCellCount)
+
+ let subnode = (copy (limb.cells @ slot-index))
+
+ # subindex
+ let index = (index - (slot-index * slot-capacity))
+ if (depth == 0)
+ return subnode
+ this-function subnode (depth - 1) index
+ default
+ if (index == 0)
+ return node
+ else
+ return (Atom)
+ recur (copy self.ivalues) (copy self.depth) index
+
+ fn next-index (self)
+ if ('none? self.ivalues)
+ return 0:u64
+ loop (node depth index = (deref self.ivalues) (copy self.depth) 0:u64)
+ dispatch node
+ case TableLimb (limb)
+ repeat
+ label found
+ for i in (rrange ArrayCellCount)
+ let node =
+ deref (limb.cells @ i)
+ if (not ('none? node))
+ maxindex := (depth-maxindex depth)
+ let slot-capacity = ((maxindex >> IndexBits) + 1)
+ merge found node
+ depth - 1
+ index + slot-capacity * i
+ else
+ assert false "unexpected end"
+ unreachable;
+ default
+ break (index + 1)
+
+ fn... append (self, value : Atom)
+ set-index self (next-index self) value
+
+ fn get-meta (self) self.meta
+
+ fn... set-meta (self, metatable : Atom)
+ assert (('kind metatable) == Atom.Kind.Table)
+ local self = (copy self)
+ self.meta = metatable
+ self
+
+ fn... set (self, key : Atom, value : Atom)
+ fn recur (keylimb valuelimb key value depth)
+ returning (uniqueof Atom -1) (uniqueof Atom -2)
+ assert (depth <= 56)
+ let mask = (((('hashbits key) >> (depth * IndexBits)) as u32) & IndexMask)
+ if (('kind keylimb) == Atom.Kind.TableLimb) # branch
+ assert (('kind valuelimb) == Atom.Kind.TableLimb)
+ local newkl = (copy (keylimb as TableLimb))
+ local newvl = (copy (valuelimb as TableLimb))
+ let currentkey = (copy (newkl.cells @ mask))
+ let subkeylimb subvaluelimb =
+ this-function currentkey (newvl.cells @ mask) key value (depth + 1)
+ flag := 1:u64 << mask
+ if ('none? subkeylimb)
+ flag := (~ flag)
+ newkl.mask &= flag
+ newvl.mask &= flag
+ else
+ newkl.mask |= flag
+ newvl.mask |= flag
+ newkl.cells @ mask = subkeylimb
+ newvl.cells @ mask = subvaluelimb
+ assert (newkl.mask != 0)
+ if ((bitcount newkl.mask) == 1)
+ let index = (findmsb newkl.mask)
+ assert (index < ArrayCellCount)
+ let node = (newkl.cells @ index)
+ assert (not ('none? node))
+ return (copy node) (copy (newvl.cells @ index))
+ else
+ return (Atom newkl) (Atom newvl)
+ elseif (('none? keylimb) or (keylimb == key)) # empty or same key
+ if ('none? value) # clear
+ return (Atom) (Atom)
+ else
+ return (copy key) (copy value)
+ else # split?
+ if ('none? value)
+ # we're removing this value anyway
+ return (copy keylimb) (copy valuelimb)
+ let oldmask = (((('hashbits keylimb) >> (depth * IndexBits)) as u32) & IndexMask)
+ local limb : TableLimb
+ for i in (range ArrayCellCount)
+ limb.cells @ i = (Atom)
+ limb.mask = 1:u64 << oldmask
+ limb.cells @ oldmask = (copy keylimb)
+ let kref = (Atom (copy limb))
+ limb.cells @ oldmask = (copy valuelimb)
+ let vref = (Atom limb)
+ return
+ this-function kref vref key value depth
+
+ label do-regular-set
+ dispatch key
+ case Number (num)
+ let index =
+ try ('toindex num)
+ else
+ merge do-regular-set
+ return (set-index self index value)
+ default;
+ let keys values = (recur self.keys self.values key value 0)
+ local self = (copy self)
+ self.keys = keys
+ self.values = values
+ self
+
+ fn... del (self, key : Atom)
+ label do-regular-del
+ dispatch key
+ case Number (num)
+ let index =
+ try ('toindex num)
+ else
+ merge do-regular-del
+ return (del-index self index)
+ default;
+ set self key (Atom)
+
+ fn... get (self, key : Atom)
+ label do-regular-get
+ dispatch key
+ case Number (num)
+ let index =
+ try ('toindex num)
+ else
+ merge do-regular-get
+ return (get-index self index)
+ default;
+ fn recur (keylimb valuelimb key depth)
+ returning (uniqueof Atom -1)
+ let mask = (((('hashbits key) >> (depth * IndexBits)) as u32) & IndexMask)
+ if (('kind keylimb) == Atom.Kind.TableLimb) # branch
+ local newkl = (copy (keylimb as TableLimb))
+ local newvl = (copy (valuelimb as TableLimb))
+ return
+ this-function (newkl.cells @ mask) (newvl.cells @ mask) key (depth + 1)
+ elseif (keylimb == key) # found key
+ return (copy valuelimb)
+ # key not found
+ return (Atom)
+ recur self.keys self.values key 0
+
+ fn new (...)
+ local table : this-type
+ va-lfold table
+ inline (key value t)
+ static-if (key == unnamed)
+ append t value
+ else
+ set t key value
+ ...
+
+# Atom
+################################################################################
+
+type UHashed < Struct
+
+ inline __typecall (cls ...)
+ static-if (cls == this-type)
+ let T hashf = ...
+ struct (.. "(UHashed " (tostring T) ")") < this-type
+ id : SHA256.DigestType
+ data : T
+
+ let HashFunction =
+ static-if (none? hashf)
+ inline (self)
+ 'uhash self
+ else hashf
+ else
+ let data = ...
+ super-type.__typecall cls
+ id = (cls.HashFunction data)
+ data = data
+
+ #fn __drop (self)
+ report "dropped"
+ assert false "what the hell"
+ #super-type.__drop self
+ ;
+
+ fn __repr (self)
+ viewing self
+ .. "(" (tostring (typeof self)) " " (repr self.data) ")"
+
+inline UType (T ...)
+ Rc (UHashed T ...)
+let
+ UNumber = (UType Number)
+ UString =
+ UType String
+ fn "uhash" (self)
+ viewing self
+ local digest : SHA256.DigestType
+ local sha : SHA256
+ 'hash sha (self as rawstring) (countof self)
+ 'digest sha digest
+ digest
+ UTableLimb = (UType TableLimb)
+ UTable = (UType Table)
+
+type+ Atom
+ enum Kind plain
+ None = 0
+ False
+ True
+ Number
+ String
+ Symbol
+ TableLimb
+ Table
+
+ inline __typecall (cls value)
+ imply value cls
+
+ fn wrap (ptr kind)
+ let origptr = ptr
+ let val = (ptrtoint ptr usize)
+ # no bits must be set
+ assert ((val & 0xf:usize) == 0:usize)
+ let ptr = (inttoptr (val | (kind as integer as usize)) voidstar)
+ static-if (plain? origptr)
+ bitcast ptr this-type
+ else
+ let self = (dupe (bitcast ptr this-type))
+ lose (move origptr)
+ self
+
+ @@ memo
+ inline __rimply (T cls)
+ static-if (T == bool)
+ inline (self)
+ wrap (null as voidstar)
+ ? self Kind.True Kind.False
+ elseif (imply? T Number)
+ inline (self)
+ self := (imply self Number)
+ wrap (UNumber self) Kind.Number
+ elseif (T == Symbol)
+ inline (self)
+ wrap (UString (String (self as string))) Kind.Symbol
+ elseif (T == TableLimb)
+ inline (self)
+ wrap (UTableLimb self) Kind.TableLimb
+ elseif (T == Table)
+ inline (self)
+ wrap (UTable self) Kind.Table
+ elseif ((imply? T String) or (T == string))
+ inline (self)
+ wrap (UString (self as String)) Kind.String
+ elseif (T == Nothing)
+ inline (self)
+ wrap (null as voidstar) Kind.None
+
+ fn topointer (self)
+ viewing self
+ inttoptr ((ptrtoint (storagecast self) usize) & (~ 0xf:usize)) voidstar
+
+ fn kind (self)
+ viewing self
+ ((ptrtoint (storagecast self) usize) & 0xf) as (storageof Kind) as Kind
+
+ @@ memo
+ inline __as (cls T)
+ static-if (T == bool)
+ inline (self)
+ switch (kind self)
+ case Kind.False false
+ case Kind.True true
+ default
+ assert false "Atom isn't a boolean"
+ unreachable;
+ elseif (T == Number)
+ inline (self)
+ assert ((kind self) == Kind.Number)
+ (bitcast (topointer self) UNumber) . data
+ elseif (T == TableLimb)
+ inline (self)
+ assert ((kind self) == Kind.TableLimb)
+ (bitcast (topointer self) UTableLimb) . data
+ elseif (T == Table)
+ inline (self)
+ assert ((kind self) == Kind.Table)
+ (bitcast (topointer self) UTable) . data
+ elseif (T == String)
+ inline (self)
+ switch (kind self)
+ pass Kind.String
+ pass Kind.Symbol
+ do
+ (bitcast (topointer self) UString) . data
+ default
+ assert false "Atom isn't a boolean"
+ unreachable;
+ elseif (T == Nothing)
+ inline (self)
+ assert ((kind self) == Kind.None)
+ none
+
+ fn... from-value (value : Value)
+ returning (uniqueof Atom -1)
+ let recur = this-function
+ let T = ('typeof value)
+ match T
+ case list
+ let l = (value as list)
+ let t =
+ fold (t = (Table)) for i elem in (enumerate l)
+ label done
+ if (('typeof elem) == list)
+ elem as:= list
+ let elemsize = (countof elem)
+ if ((elemsize >= 2) & (elemsize <= 3))
+ let head key value = (decons elem 3)
+ if (('typeof head) == Symbol)
+ head as:= Symbol
+ switch head
+ pass 'square-list
+ pass ':
+ do
+ key := (recur key)
+ let value =
+ if (elemsize == 3)
+ recur value
+ else
+ Atom true
+ merge done
+ 'set t key value
+ default;
+ key := (recur elem)
+ 'append t key
+ return (t as Atom)
+ case string
+ return (value as string as Atom)
+ case Symbol
+ let sym = (value as Symbol)
+ switch sym
+ case 'none
+ return (Atom)
+ case 'false
+ return (false as Atom)
+ case 'true
+ return (true as Atom)
+ case 'sugar-quote
+ return ('quote as Atom)
+ case 'spice-quote
+ return ('qquote as Atom)
+ default
+ return (sym as Atom)
+ case Nothing
+ return (Atom)
+ case bool
+ return (value as bool as Atom)
+ default
+ let ST = ('storageof T)
+ let tk = ('kind ST)
+ switch tk
+ case type-kind-integer
+ let value = (sc_const_int_extract value)
+ if ('signed? ST)
+ return (Atom (value as i64))
+ else
+ return (Atom value)
+ case type-kind-real
+ return (Atom (sc_const_real_extract value))
+ default;
+ report "unable to handle type" (repr T)
+ error (.. "unable to handle type" (repr T))
+
+ @@ memo
+ inline __ras (T cls)
+ static-if (T == Value) from-value
+
+ fn kind-from-digest (digest)
+ (((digest @ 3) >> 60) & 0xf:u64) as i32 as Kind
+
+ fn uhash (self)
+ let ptr = (topointer self)
+ let kind = ('kind self)
+ let digest =
+ switch kind
+ case Kind.Number
+ copy ((bitcast ptr UNumber) . id)
+ pass Kind.Symbol
+ pass Kind.String
+ do
+ copy ((bitcast ptr UString) . id)
+ case Kind.TableLimb
+ copy ((bitcast ptr UTableLimb) . id)
+ case Kind.Table
+ copy ((bitcast ptr UTable) . id)
+ default
+ nullof SHA256.DigestType
+ # embed kind bits into most significant bits of digest
+ let kindmask = (0xf:u64 << 60)
+ let kindbits = (kind as integer as u64 << 60)
+ insertvalue digest
+ ((digest @ 3) & (~ kindmask)) | kindbits
+ 3
+
+ fn hashbits (self)
+ local digest = (uhash self)
+ static-assert ((sizeof digest) == (sizeof u256))
+ @ (bitcast &digest @u256)
+
+ inline hash-from-digest (digest)
+ (digest @ 3) as u64 as hash
+
+ fn __hash (self)
+ hash-from-digest ('uhash self)
+
+ @@ memo
+ inline __== (cls T)
+ static-if (cls == T)
+ inline (self other)
+ ('uhash self) == ('uhash other)
+ elseif (T == SHA256.DigestType)
+ inline (self other)
+ ('uhash self) == other
+
+ spice __dispatch (self handlers...)
+ let ptr = `(topointer self)
+ let tag = `('kind self)
+ let sw = (sc_switch_new tag)
+ for arg in ('args handlers...)
+ let anchor = ('anchor arg)
+ let key arg = ('dekey arg)
+ if (key == unnamed)
+ sc_switch_append_default sw `(arg)
+ else
+ let lit = ('@ Kind key)
+ let val = (lit as Kind)
+ inline append-case (...)
+ sc_switch_append_case sw lit ('tag `(arg ...) anchor)
+ switch val
+ case Kind.Number
+ append-case `((bitcast ptr UNumber) . data)
+ pass Kind.String
+ pass Kind.Symbol
+ do
+ append-case `((bitcast ptr UString) . data)
+ case Kind.TableLimb
+ append-case `((bitcast ptr UTableLimb) . data)
+ case Kind.Table
+ append-case `((bitcast ptr UTable) . data)
+ default
+ append-case;
+ spice-quote
+ do ptr
+ sw
+
+ @@ spice-quote
+ fn __repr (self)
+ .. "(Atom "
+ dispatch self
+ case None () "none"
+ case False () "false"
+ case True () "true"
+ case Number (n) (repr n)
+ case String (n) (repr (n as string))
+ case Symbol (n) (n as string)
+ case TableLimb (n)
+ local digest = ('uhash self)
+ ..
+ tostring ('kind self)
+ " "
+ (sha256-digest-string digest) as string
+ case Table (n)
+ local digest = ('uhash self)
+ ..
+ tostring ('kind self)
+ " "
+ (sha256-digest-string digest) as string
+ default "?"
+ ")"
+
+ fn tostring (self)
+ #returning String
+
+ let uatom-repr = this-function
+
+ dispatch self
+ case None () "none"
+ return (String (default-styler style-number "none"))
+ case False () "false"
+ return (String (default-styler style-number "false"))
+ case True () "true"
+ return (String (default-styler style-number "true"))
+ case Number (num)
+ let str = (('tostring num) as string)
+ return
+ String (default-styler style-number str)
+ case String (str)
+ let str = (str as string)
+ String
+ repr str
+ case Symbol (str)
+ let str = (Symbol (str as string))
+ String
+ repr str
+ case Table (table)
+ local str : String
+ 'append str "("
+ let f =
+ Table.gen-each-index
+ inline (index node str count)
+ if (count > 0)
+ 'append str " "
+ let strval = (uatom-repr node)
+ if (count != index)
+ 'append str "(: "
+ 'append str
+ default-styler style-number (tostring index)
+ 'append str " "
+ 'append str strval
+ 'append str ")"
+ else
+ 'append str strval
+ count += 1
+ local count = 0
+ f table str count
+ let f =
+ Table.gen-each-pair
+ inline (key value str count)
+ if (count > 0)
+ 'append str " "
+ 'append str "(: "
+ 'append str (uatom-repr key)
+ 'append str " "
+ 'append str (uatom-repr value)
+ 'append str ")"
+ count += 1
+ f table str count
+ 'append str ")"
+ deref str
+ default
+ String
+ repr self
+
+ fn __copy (self)
+ viewing self
+ let ptr = (topointer self)
+ if (ptr != null)
+ wrap (copy (bitcast ptr (Rc voidstar))) ('kind self)
+ else
+ deref (dupe self)
+
+ fn __drop (self)
+ viewing self
+ returning void
+ let ptr = (topointer self)
+ switch ('kind self)
+ case Kind.Number
+ __drop (bitcast ptr UNumber)
+ pass Kind.Symbol
+ pass Kind.String
+ do
+ __drop (bitcast ptr UString)
+ case Kind.TableLimb
+ __drop (bitcast ptr UTableLimb)
+ case Kind.Table
+ __drop (bitcast ptr UTable)
+ default;
+
+ fn none? (self)
+ ('kind self) == Kind.None
+
+run-stage;
+
+sugar uquote (expr...)
+ qq [Atom.from-value] ([sugar-quote] (unquote-splice expr...))
+
+# Evaluation
+################################################################################
+
+let builtins global-env =
+ fold (scope env = (Scope) (Table)) for name in
+ sugar-quote + - * / let fn quote set get nextindex _
+ sym := (Atom (name as Symbol))
+ code := ('hashbits sym)
+ _
+ 'bind scope name `code
+ 'set env sym sym
+
+global global-env : Atom = global-env
+
+run-stage;
+
+global mt_closure : Atom =
+ Table.new
+ type = "closure"
+
+fn global-environment ()
+ global-env
+
+fn... ueval (env : Atom, expr : Atom)
+ let ueval = this-function
+
+ assert (('kind env) == Atom.Kind.Table)
+ let envtable = (env as Table)
+ switch ('kind expr)
+ case Atom.Kind.Symbol
+ return ('get envtable expr)
+ case Atom.Kind.Table
+ let head =
+ ueval env ('get-index (expr as Table) 0)
+ switch ('kind head)
+ case Atom.Kind.Symbol
+ let args = (expr as Table)
+
+ switch ('hashbits head)
+ # (let (: k v) ... expr)
+ case builtins.let
+ let f =
+ Table.gen-each-pair
+ inline (k v origenv env)
+ env =
+ 'set env (copy k)
+ ueval origenv (copy v)
+ ;
+ local newenv = (copy (env as Table))
+ f args env newenv
+ return (ueval newenv ('get args 1))
+ # (fn (param ...) expr)
+ case builtins.fn
+ return
+ Atom
+ 'set-meta
+ Table.new (copy env) (copy expr)
+ copy mt_closure
+ # (quote value)
+ case builtins.quote
+ return ('get-index args 1)
+ default;
+ default;
+
+ # evaluate all table elements
+ let args =
+ do
+ local args = (Table)
+ let table = (expr as Table)
+ call
+ Table.gen-each-index
+ inline (index node result env)
+ if (index > 0)
+ result =
+ 'set-index result (index - 1) (ueval env node)
+ \ table args env
+ call
+ Table.gen-each-pair
+ inline (key value result env)
+ result =
+ 'set result
+ if (('kind key) == Atom.Kind.Symbol) (copy key)
+ else (ueval env key)
+ ueval env value
+ \ table args env
+ deref args
+
+ switch ('kind head)
+ case Atom.Kind.Table
+ let headtable = (head as Table)
+ if (('get-meta headtable) == mt_closure)
+ let origenv = env
+ local env = (copy (('get-index headtable 0) as Table))
+ let f = ('get-index headtable 1)
+ let ftable = (f as Table)
+ let params = ('get-index ftable 1)
+ let tparams = (params as Table)
+ let eachf =
+ Table.gen-each-index
+ inline (i name origenv env args)
+ let value = ('get-index args i)
+ env =
+ 'set env name
+ if ('none? value)
+ 'get args name
+ else value
+ ;
+ eachf tparams origenv env (args as Table)
+ let expr = ('get-index ftable 2)
+ return (ueval env expr)
+ else
+ print "cannot apply table:" ('tostring expr)
+ return (Atom)
+ case Atom.Kind.Symbol
+ let table = (expr as Table)
+
+ fn verify (val K)
+ if (('kind val) != K)
+ print K "expected, got" ('tostring val)
+ fn verify-bool (val)
+ switch ('kind val)
+ pass Atom.Kind.False
+ pass Atom.Kind.True
+ do;
+ default
+ print "boolean expected, got" ('tostring val)
+
+ inline binop (f)
+ let a = ('get-index args 0)
+ verify a Atom.Kind.Number
+ let b = ('get-index args 1)
+ verify b Atom.Kind.Number
+ return (Atom (f (a as Number) (b as Number)))
+
+ inline eval-set ()
+ let source = ('get-index args 0)
+ verify source Atom.Kind.Table
+ source as:= Table
+ let key = ('get-index args 1)
+ let value = ('get-index args 2)
+ Atom ('set source key value)
+
+ inline eval-get ()
+ let source = ('get-index args 0)
+ verify source Atom.Kind.Table
+ source as:= Table
+ let key = ('get-index args 1)
+ let value = ('get-index args 2)
+ let result = ('get source key)
+ if ('none? result)
+ value
+ else
+ result
+
+ inline eval-countof ()
+ let source = ('get-index args 0)
+ verify source Atom.Kind.Table
+ source as:= Table
+ Atom ('next-index source)
+
+ switch ('hashbits head)
+ case builtins.+ (binop +)
+ case builtins.- (binop -)
+ case builtins.* (binop *)
+ case builtins./ (binop /)
+ # (set table key value)
+ case builtins.set (eval-set)
+ # (get table key default)
+ case builtins.get (eval-get)
+ # (countof table)
+ case builtins.nextindex (eval-countof)
+ case builtins._
+ return (Atom args)
+ default
+ print "syntax error:" ('tostring expr)
+ return (Atom)
+ default
+ print "cannot apply:" ('tostring expr)
+ return (Atom)
+ default
+ return (copy expr)
+
+###############################################################################
+
+do
+ let Number Table Atom UString TableLimb
+ let uquote
+ let global-environment ueval
+
+ locals;
M testing/test_uvm3.sc +4 -2049
@@ 7,2056 7,11 @@ using import String
using import Rc
import ..lib.tukan.use
-using import tukan.libbf
-using import tukan.thread
-using import tukan.SHA256
-
-# features:
- * six value types: none, bool, bigfloat, string, symbol, map
- * a pure functional evaluator without mutation, recursion or other side effects
- * GC free, refcount based memory management
- * any value can be used as a key in a map
-
- in progress:
- * pickle/unpickle
-
-let u256 = (integer 256)
-
-###############################################################################
-
-inline verify-sizeof (size)
- inline (T)
- #static-assert ((alignof T) == 8)
- .. "(alignof " (tostring T) ") != 8"
- static-assert ((sizeof T) == size)
- .. "(sizeof " (tostring T) ") == "
- \ (tostring (sizeof T)) " != " (tostring size)
- T
-
-# Number
-###############################################################################
-
-let realloc =
- extern 'realloc
- function voidstar voidstar usize
-fn urealloc (opaque ptr size)
- realloc ptr size
-
-struct NumberContext
- ctx : bf_context_t
-
- inline __typecall (cls)
- local self =
- super-type.__typecall cls
- bf_context_init &self.ctx urealloc null
- self
-
- fn __drop (self)
- bf_context_end &self.ctx
- ;
-
-global _number_context =
- LocalStorage
- fn () (NumberContext)
-inline bfcontext ()
- & ((@ _number_context) . ctx)
-unlet _number_context
-
-type Number :: (storageof bf_t)
-
- let DEFAULT_PREC = 56
- let CType = @bf_t
- let MutableCType = (mutable @bf_t)
-
- inline... set
- case (self)
- bf_set_zero self 0
- case (self, value : Nothing)
- case (self, value : i64)
- bf_set_si self value
- case (self, value : u64)
- bf_set_ui self value
- case (self, value : integer)
- bf_set_si self value
- case (self, value : real)
- bf_set_float64 self value
- case (self, value : &bf_t)
- bf_set self &value
- case (self, value : this-type)
- bf_set self value
-
- inline __typecall (cls ...)
- local self : bf_t
- bf_init (bfcontext) &self
- let self = (bitcast self cls)
- set self ...
- self
-
- @@ memo
- inline writer (f)
- fn write (self ...)
- viewing self
- let index =
- try ('toindex32 self)
- else
- let self = (bitcast self bf_t)
- va-map
- inline (name)
- let member = (getattr self name)
- f (&member as rawstring) (sizeof member) ...
- \ 'sign 'expn 'len
- f (self.tab as rawstring) ((sizeof (self.tab @ 0)) * self.len) ...
- return;
- local index : i32 = (- (index as i32))
- f (&index as rawstring) (sizeof index) ...
- ;
-
- @@ memo
- inline reader (f)
- fn read (...)
- local index : i32
- f (&index as rawstring) (sizeof index) ...
- if (index < 0)
- return (this-type -index)
- local source : bf_t
- source.sign = index
- va-map
- inline (name)
- let member = (getattr source name)
- f (&member as rawstring) (sizeof member) ...
- \ 'expn 'len
- let limbT = (typeof (source.tab @ 0))
- source.tab = (alloca-array limbT source.len)
- f (source.tab as rawstring) ((sizeof limbT) * source.len) ...
- this-type source
-
- let sha-writer =
- writer
- inline (data size sha)
- 'hash sha data size
-
- fn uhash (self)
- viewing self
- local digest : SHA256.DigestType
- local sha : SHA256
- sha-writer self sha
- 'digest sha digest
- digest
-
- fn __drop (self)
- let self =
- static-if (&? self) self
- else (local self = self)
- bf_delete self
-
- inline __copy (self)
- this-type self
-
- fn toi32 (self)
- local outp : i32
- bf_get_int32 &outp self 0
- outp
- fn toi64 (self)
- local outp : i64
- bf_get_int64 &outp self 0
- outp
- fn tof64 (self)
- local outp : f64
- bf_get_float64 self &outp bf_rnd_t.BF_RNDN
- outp
-
- fn toindex32 (self)
- if (self >= 0)
- if (self <= 0x7fffffff:i32)
- if (('floor self) == self)
- return ((toi32 self) as u32)
- raise;
-
- fn toindex (self)
- if (self >= 0)
- if (self <= 0x7fffffffffffffff:i64)
- if (('floor self) == self)
- return ((toi64 self) as u64)
- raise;
-
- @@ memo
- inline __as (cls T)
- static-match T
- case integer toi32
- case i32 toi32
- case i64 toi64
- case real tof64
- case f64 tof64
- default;
-
- unlet toi32 toi64 tof64
-
- @@ memo
- inline __imply (cls T)
- static-if ((&? cls) and ((T == CType) or (T == MutableCType)))
- inline (self) (& (bitcast (view self) bf_t))
-
- @@ memo
- inline __rimply (T cls)
- static-if ((T < integer) or (T < real))
- inline (self)
- cls self
-
- fn tostring (self)
- local sz : u64
- let s =
- bf_ftoa &sz self 10 DEFAULT_PREC BF_FTOA_FORMAT_FREE_MIN
- String s sz
-
- fn __repr (self)
- (tostring self) as string
-
- fn cmp (self other)
- bf_cmp self other
-
- inline cmpfn (op)
- @@ memo
- inline (cls T)
- static-if (cls == T)
- inline (a b) (op (cmp a b) 0)
-
- inline op0ifn (f ...)
- inline (self)
- let result = (this-type self)
- f result ...
- result
-
- inline op1fn (f ...)
- inline (self)
- let result = (this-type none)
- f result self ...
- result
-
- inline op2fn (f ...)
- @@ memo
- inline (cls T)
- static-if (cls == T)
- inline (a b)
- let result = (this-type none)
- f result (view a) (view b) ...
- result
-
- inline op2r2fn (f ...)
- @@ memo
- inline (cls T)
- static-if (cls == T)
- inline (a b)
- let result1 = (this-type none)
- let result2 = (this-type none)
- f result1 result2 (view a) (view b) ...
- result1
-
- let
- __== = (cmpfn ==)
- __!= = (cmpfn !=)
- __>= = (cmpfn >=)
- __<= = (cmpfn <=)
- __> = (cmpfn >)
- __< = (cmpfn <)
-
- let
- __+ = (op2fn bf_add DEFAULT_PREC 0)
- __- = (op2fn bf_sub DEFAULT_PREC 0)
- __* = (op2fn bf_mul DEFAULT_PREC 0)
- __/ = (op2fn bf_div DEFAULT_PREC 0)
- __// = (op2r2fn bf_divrem DEFAULT_PREC 0 bf_rnd_t.BF_RNDZ)
- __% = (op2fn bf_rem DEFAULT_PREC 0 bf_rnd_t.BF_RNDZ)
-
- __** = (op2fn bf_pow DEFAULT_PREC 0)
- atan2 = (op2fn bf_atan2 DEFAULT_PREC 0)
-
- __| = (op2fn bf_logic_or)
- __^ = (op2fn bf_logic_xor)
- __& = (op2fn bf_logic_and)
-
- let __neg = (op0ifn bf_neg)
-
- let
- sqrt = (op1fn bf_sqrt DEFAULT_PREC 0)
- exp = (op1fn bf_exp DEFAULT_PREC 0)
- log = (op1fn bf_log DEFAULT_PREC 0)
- cos = (op1fn bf_cos DEFAULT_PREC 0)
- sin = (op1fn bf_sin DEFAULT_PREC 0)
- tan = (op1fn bf_tan DEFAULT_PREC 0)
- atan = (op1fn bf_atan DEFAULT_PREC 0)
- asin = (op1fn bf_asin DEFAULT_PREC 0)
- acos = (op1fn bf_acos DEFAULT_PREC 0)
-
- floor = (op0ifn bf_rint bf_rnd_t.BF_RNDZ)
- round = (op0ifn bf_rint bf_rnd_t.BF_RNDN)
-
- unlet cmpfn op2fn op0ifn op1fn
-
-################################################################################
-
-type UAtom :: voidstar
-
-# Table
-################################################################################
-
-let IndexBits = 4
-let ArrayCellCount = (1 << IndexBits)
-let IndexMask = (ArrayCellCount - 1)
-let CellIndexType = u16
-
-fn depth-maxindex (depth)
- ((ArrayCellCount as u64) << (depth * IndexBits)) - 1
-
-@@ verify-sizeof 136
-struct TableLimb
- cells : (array UAtom ArrayCellCount)
- mask : u64 = 0 # slots used
-
- @@ memo
- inline writer (f hashf)
- fn write (self ...)
- viewing self
- local mask : CellIndexType = (self.mask as CellIndexType)
- f (&mask as rawstring) (sizeof mask) ...
- local celldigest : SHA256.DigestType
- inline handle-cell (i)
- if ((mask & (1 << i)) != 0)
- celldigest = ('uhash (self.cells @ i))
- hashf (&celldigest as rawstring) (sizeof celldigest) ...
- static-if (&? self)
- for i in (range ArrayCellCount) (handle-cell i)
- else
- va-map handle-cell (va-range ArrayCellCount)
-
- @@ memo
- inline reader (f hashf)
- fn read (cache ...)
- local limb : this-type
- local mask : CellIndexType
- f (&mask as rawstring) (sizeof mask) ...
- limb.mask = mask
- local celldigest : SHA256.DigestType
- for i in (range ArrayCellCount)
- if ((limb.mask & (1 << i)) != 0)
- hashf (&celldigest as rawstring) (sizeof celldigest) ...
- limb.cells @ i =
- do
- try
- copy
- 'get cache celldigest
- else
- report "TableLimb cell missing:"
- sha256-digest-string celldigest
- \ "(" (UAtom.kind-from-digest celldigest) ")"
- UAtom;
- limb
-
- let sha-writer =
- writer
- inline (data size sha)
- 'hash sha data size
- inline (data size sha)
- 'hash sha data size
-
- fn uhash (self)
- viewing self
- local digest : SHA256.DigestType
- local sha : SHA256
- sha-writer self sha
- 'digest sha digest
- digest
-
- fn __copy (self)
- viewing self
- super-type.__typecall this-type
- cells = (typeinit (va-map copy (unpack self.cells)))
- mask = self.mask
-
- fn __repr (self) "<TableLimb>"
-
-@@ verify-sizeof 40
-struct Table
- meta : UAtom
- keys : UAtom
- values : UAtom
- ivalues : UAtom
- depth : u64
-
- fn __copy (self)
- viewing self
- super-type.__typecall this-type
- meta = (copy self.meta)
- keys = (copy self.keys)
- values = (copy self.values)
- ivalues = (copy self.ivalues)
- depth = self.depth
-
- @@ memo
- inline writer (f hashf)
- fn write (self ...)
- viewing self
- local memberdigest : SHA256.DigestType
- va-map
- inline (name)
- let member = (getattr self name)
- memberdigest = ('uhash member)
- hashf (&memberdigest as rawstring) (sizeof memberdigest) ...
- \ 'meta 'keys 'values 'ivalues
- local depth = self.depth
- f (&depth as rawstring) (sizeof depth) ...
-
- @@ memo
- inline reader (f hashf)
- fn read (cache ...)
- returning (uniqueof this-type -1)
- local memberdigest : SHA256.DigestType
- local table : this-type
- va-map
- inline (name)
- let member = (getattr table name)
- hashf (&memberdigest as rawstring) (sizeof memberdigest) ...
- member =
- do
- try
- copy
- 'get cache memberdigest
- else
- report "Table member missing"
- sha256-digest-string memberdigest
- \ "(" (UAtom.kind-from-digest memberdigest) ")"
- UAtom;
- \ 'meta 'keys 'values 'ivalues
- f (&table.depth as rawstring) (sizeof table.depth) ...
- table
-
- let sha-writer =
- writer
- inline (data size sha)
- 'hash sha data size
- inline (data size sha)
- 'hash sha data size
-
- fn uhash (self)
- viewing self
- local digest : SHA256.DigestType
- local sha : SHA256
- sha-writer self sha
- 'digest sha digest
- digest
-
- @@ memo
- inline gen-each-index (f)
- fn process (table ...)
- fn recur (node depth index ...)
- returning void
- dispatch node
- case TableLimb (limb)
- let maxindex = (depth-maxindex depth)
- let slot-capacity = ((maxindex >> IndexBits) + 1)
- for i in (range ArrayCellCount)
- let index = (index + slot-capacity * i)
- this-function
- limb.cells @ i
- depth - 1
- index
- ...
- case None ()
- default
- f index node ...
- recur table.ivalues table.depth 0:u64 ...
-
- @@ memo
- inline gen-each-pair (f)
- fn process (table ...)
- fn recur (key value ...)
- returning void
- dispatch key
- case TableLimb (klimb)
- dispatch value
- case TableLimb (vlimb)
- let kl = klimb.cells
- let vl = vlimb.cells
- for i in (range ArrayCellCount)
- let k v =
- kl @ i
- vl @ i
- this-function k v ...
- default
- assert false "table structure: internal error"
- unreachable;
- case None ()
- default
- f key value ...
- recur table.keys table.values ...
-
- fn __repr (self) "<Table>"
-
- fn capacity (self)
- depth-maxindex (copy self.depth)
-
- fn... set-index (self, index : u64, value : UAtom)
- let value = (move value)
-
- fn recur (node depth index value)
- returning (uniqueof UAtom -1) u64
- #raising (uniqueof UError -1)
-
- if (index == 0)
- # truncate
- return value depth
-
- node := (copy node)
- maxindex := (depth-maxindex depth)
- let node depth =
- if (index > maxindex)
- # exceeding existing capacity
- if ('none? value)
- # nothing to do
- return node depth
- if ('none? node)
- # increase depth until it fits
- _ node
- loop (depth = depth)
- let newdepth = (depth + 1)
- maxindex := (depth-maxindex newdepth)
- if (index > maxindex)
- repeat newdepth
- else
- break newdepth
- else
- loop (node depth = (copy node) depth)
- let newdepth = (depth + 1)
- maxindex := (depth-maxindex newdepth)
- # split
- local newlimb = (TableLimb)
- newlimb.mask = 1
- newlimb.cells @ 0 = node
- for i in (range 1 ArrayCellCount)
- newlimb.cells @ i = (UAtom)
- let node = (UAtom newlimb)
- if (index > maxindex)
- repeat node newdepth
- else
- break node newdepth
- else
- _ node depth
-
- let newlimb =
- dispatch node
- case TableLimb (limb)
- local newlimb = (copy limb)
- default
- # split
- local newlimb : TableLimb
- if (not ('none? node))
- newlimb.mask = 1
- newlimb.cells @ 0 = node
- for i in (range 1 ArrayCellCount)
- newlimb.cells @ i = (UAtom)
- newlimb
-
- maxindex := (depth-maxindex depth)
- let slot-capacity = ((maxindex >> IndexBits) + 1)
- let slot-index = (index // slot-capacity)
- assert (slot-index < ArrayCellCount)
-
- # subindex
- let index = (index - (slot-index * slot-capacity))
- let value newdepth =
- if (depth == 0)
- _ (copy value) depth
- else
- let value depth =
- this-function (newlimb.cells @ slot-index) (depth - 1) index value
- _ value (depth + 1)
- flag := 1:u64 << slot-index
- if ('none? value)
- newlimb.mask &= (~ flag)
- else
- newlimb.mask |= flag
- if (newlimb.mask == 0) # empty
- return (UAtom) depth
- else
- newlimb.cells @ slot-index = value
- return
- UAtom newlimb
- newdepth
- # truncate excess capacity
- let node depth =
- loop (node depth = (recur self.ivalues (copy self.depth) index value))
- dispatch node
- case TableLimb (limb)
- if (limb.mask == 1)
- repeat
- copy (limb.cells @ 0)
- depth - 1
- default;
- break node depth
- local self = (copy self)
- self.ivalues = node
- self.depth = depth
- self
-
- fn... del-index (self, index : u64)
- set-index self index (UAtom)
-
- fn... get-index (self, index : u64)
- fn recur (node depth index)
- returning (uniqueof UAtom -1)
- #raising (uniqueof UError -1)
-
- node := (copy node)
-
- maxindex := (depth-maxindex depth)
- if (index > maxindex)
- return (UAtom)
-
- dispatch node
- case TableLimb (limb)
- let slot-capacity = ((maxindex >> IndexBits) + 1)
- let slot-index = (index // slot-capacity)
- assert (slot-index < ArrayCellCount)
-
- let subnode = (copy (limb.cells @ slot-index))
-
- # subindex
- let index = (index - (slot-index * slot-capacity))
- if (depth == 0)
- return subnode
- this-function subnode (depth - 1) index
- default
- if (index == 0)
- return node
- else
- return (UAtom)
- recur (copy self.ivalues) (copy self.depth) index
-
- fn next-index (self)
- if ('none? self.ivalues)
- return 0:u64
- loop (node depth index = (deref self.ivalues) (copy self.depth) 0:u64)
- dispatch node
- case TableLimb (limb)
- repeat
- label found
- for i in (rrange ArrayCellCount)
- let node =
- deref (limb.cells @ i)
- if (not ('none? node))
- maxindex := (depth-maxindex depth)
- let slot-capacity = ((maxindex >> IndexBits) + 1)
- merge found node
- depth - 1
- index + slot-capacity * i
- else
- assert false "unexpected end"
- unreachable;
- default
- break (index + 1)
-
- fn... append (self, value : UAtom)
- set-index self (next-index self) value
-
- fn get-meta (self) self.meta
-
- fn... set-meta (self, metatable : UAtom)
- assert (('kind metatable) == UAtom.Kind.Table)
- local self = (copy self)
- self.meta = metatable
- self
-
- fn... set (self, key : UAtom, value : UAtom)
- fn recur (keylimb valuelimb key value depth)
- returning (uniqueof UAtom -1) (uniqueof UAtom -2)
- assert (depth <= 56)
- let mask = (((('hashbits key) >> (depth * IndexBits)) as u32) & IndexMask)
- if (('kind keylimb) == UAtom.Kind.TableLimb) # branch
- assert (('kind valuelimb) == UAtom.Kind.TableLimb)
- local newkl = (copy (keylimb as TableLimb))
- local newvl = (copy (valuelimb as TableLimb))
- let currentkey = (copy (newkl.cells @ mask))
- let subkeylimb subvaluelimb =
- this-function currentkey (newvl.cells @ mask) key value (depth + 1)
- flag := 1:u64 << mask
- if ('none? subkeylimb)
- flag := (~ flag)
- newkl.mask &= flag
- newvl.mask &= flag
- else
- newkl.mask |= flag
- newvl.mask |= flag
- newkl.cells @ mask = subkeylimb
- newvl.cells @ mask = subvaluelimb
- assert (newkl.mask != 0)
- if ((bitcount newkl.mask) == 1)
- let index = (findmsb newkl.mask)
- assert (index < ArrayCellCount)
- let node = (newkl.cells @ index)
- assert (not ('none? node))
- return (copy node) (copy (newvl.cells @ index))
- else
- return (UAtom newkl) (UAtom newvl)
- elseif (('none? keylimb) or (keylimb == key)) # empty or same key
- if ('none? value) # clear
- return (UAtom) (UAtom)
- else
- return (copy key) (copy value)
- else # split?
- if ('none? value)
- # we're removing this value anyway
- return (copy keylimb) (copy valuelimb)
- let oldmask = (((('hashbits keylimb) >> (depth * IndexBits)) as u32) & IndexMask)
- local limb : TableLimb
- for i in (range ArrayCellCount)
- limb.cells @ i = (UAtom)
- limb.mask = 1:u64 << oldmask
- limb.cells @ oldmask = (copy keylimb)
- let kref = (UAtom (copy limb))
- limb.cells @ oldmask = (copy valuelimb)
- let vref = (UAtom limb)
- return
- this-function kref vref key value depth
-
- label do-regular-set
- dispatch key
- case Number (num)
- let index =
- try ('toindex num)
- else
- merge do-regular-set
- return (set-index self index value)
- default;
- let keys values = (recur self.keys self.values key value 0)
- local self = (copy self)
- self.keys = keys
- self.values = values
- self
-
- fn... del (self, key : UAtom)
- label do-regular-del
- dispatch key
- case Number (num)
- let index =
- try ('toindex num)
- else
- merge do-regular-del
- return (del-index self index)
- default;
- set self key (UAtom)
-
- fn... get (self, key : UAtom)
- label do-regular-get
- dispatch key
- case Number (num)
- let index =
- try ('toindex num)
- else
- merge do-regular-get
- return (get-index self index)
- default;
- fn recur (keylimb valuelimb key depth)
- returning (uniqueof UAtom -1)
- let mask = (((('hashbits key) >> (depth * IndexBits)) as u32) & IndexMask)
- if (('kind keylimb) == UAtom.Kind.TableLimb) # branch
- local newkl = (copy (keylimb as TableLimb))
- local newvl = (copy (valuelimb as TableLimb))
- return
- this-function (newkl.cells @ mask) (newvl.cells @ mask) key (depth + 1)
- elseif (keylimb == key) # found key
- return (copy valuelimb)
- # key not found
- return (UAtom)
- recur self.keys self.values key 0
-
- fn new (...)
- local table : this-type
- va-lfold table
- inline (key value t)
- static-if (key == unnamed)
- append t value
- else
- set t key value
- ...
-
-# UAtom
-################################################################################
-
-type UHashed < Struct
-
- inline __typecall (cls ...)
- static-if (cls == this-type)
- let T hashf = ...
- struct (.. "(UHashed " (tostring T) ")") < this-type
- id : SHA256.DigestType
- data : T
-
- let HashFunction =
- static-if (none? hashf)
- inline (self)
- 'uhash self
- else hashf
- else
- let data = ...
- super-type.__typecall cls
- id = (cls.HashFunction data)
- data = data
-
- #fn __drop (self)
- report "dropped"
- assert false "what the hell"
- #super-type.__drop self
- ;
-
- fn __repr (self)
- viewing self
- .. "(" (tostring (typeof self)) " " (repr self.data) ")"
-
-inline UType (T ...)
- Rc (UHashed T ...)
-let
- UNumber = (UType Number)
- UString =
- UType String
- fn "uhash" (self)
- viewing self
- local digest : SHA256.DigestType
- local sha : SHA256
- 'hash sha (self as rawstring) (countof self)
- 'digest sha digest
- digest
- UTableLimb = (UType TableLimb)
- UTable = (UType Table)
-
-type+ UAtom
- enum Kind plain
- None = 0
- False
- True
- Number
- String
- Symbol
- TableLimb
- Table
-
- inline __typecall (cls value)
- imply value cls
-
- fn wrap (ptr kind)
- let origptr = ptr
- let val = (ptrtoint ptr usize)
- # no bits must be set
- assert ((val & 0xf:usize) == 0:usize)
- let ptr = (inttoptr (val | (kind as integer as usize)) voidstar)
- static-if (plain? origptr)
- bitcast ptr this-type
- else
- let self = (dupe (bitcast ptr this-type))
- lose (move origptr)
- self
-
- @@ memo
- inline __rimply (T cls)
- static-if (T == bool)
- inline (self)
- wrap (null as voidstar)
- ? self Kind.True Kind.False
- elseif (imply? T Number)
- inline (self)
- self := (imply self Number)
- wrap (UNumber self) Kind.Number
- elseif (T == Symbol)
- inline (self)
- wrap (UString (String (self as string))) Kind.Symbol
- elseif (T == TableLimb)
- inline (self)
- wrap (UTableLimb self) Kind.TableLimb
- elseif (T == Table)
- inline (self)
- wrap (UTable self) Kind.Table
- elseif ((imply? T String) or (T == string))
- inline (self)
- wrap (UString (self as String)) Kind.String
- elseif (T == Nothing)
- inline (self)
- wrap (null as voidstar) Kind.None
-
- fn topointer (self)
- viewing self
- inttoptr ((ptrtoint (storagecast self) usize) & (~ 0xf:usize)) voidstar
-
- fn kind (self)
- viewing self
- ((ptrtoint (storagecast self) usize) & 0xf) as (storageof Kind) as Kind
-
- @@ memo
- inline __as (cls T)
- static-if (T == bool)
- inline (self)
- switch (kind self)
- case Kind.False false
- case Kind.True true
- default
- assert false "UAtom isn't a boolean"
- unreachable;
- elseif (T == Number)
- inline (self)
- assert ((kind self) == Kind.Number)
- (bitcast (topointer self) UNumber) . data
- elseif (T == TableLimb)
- inline (self)
- assert ((kind self) == Kind.TableLimb)
- (bitcast (topointer self) UTableLimb) . data
- elseif (T == Table)
- inline (self)
- assert ((kind self) == Kind.Table)
- (bitcast (topointer self) UTable) . data
- elseif (T == String)
- inline (self)
- switch (kind self)
- pass Kind.String
- pass Kind.Symbol
- do
- (bitcast (topointer self) UString) . data
- default
- assert false "UAtom isn't a boolean"
- unreachable;
- elseif (T == Nothing)
- inline (self)
- assert ((kind self) == Kind.None)
- none
-
- fn... from-value (value : Value)
- returning (uniqueof UAtom -1)
- let recur = this-function
- let T = ('typeof value)
- match T
- case list
- let l = (value as list)
- let t =
- fold (t = (Table)) for i elem in (enumerate l)
- label done
- if (('typeof elem) == list)
- elem as:= list
- let elemsize = (countof elem)
- if ((elemsize >= 2) & (elemsize <= 3))
- let head key value = (decons elem 3)
- if (('typeof head) == Symbol)
- head as:= Symbol
- switch head
- pass 'square-list
- pass ':
- do
- key := (recur key)
- let value =
- if (elemsize == 3)
- recur value
- else
- UAtom true
- merge done
- 'set t key value
- default;
- key := (recur elem)
- 'append t key
- return (t as UAtom)
- case string
- return (value as string as UAtom)
- case Symbol
- let sym = (value as Symbol)
- switch sym
- case 'none
- return (UAtom)
- case 'false
- return (false as UAtom)
- case 'true
- return (true as UAtom)
- case 'sugar-quote
- return ('quote as UAtom)
- case 'spice-quote
- return ('qquote as UAtom)
- default
- return (sym as UAtom)
- case Nothing
- return (UAtom)
- case bool
- return (value as bool as UAtom)
- default
- let ST = ('storageof T)
- let tk = ('kind ST)
- switch tk
- case type-kind-integer
- let value = (sc_const_int_extract value)
- if ('signed? ST)
- return (UAtom (value as i64))
- else
- return (UAtom value)
- case type-kind-real
- return (UAtom (sc_const_real_extract value))
- default;
- report "unable to handle type" (repr T)
- error (.. "unable to handle type" (repr T))
-
- @@ memo
- inline __ras (T cls)
- static-if (T == Value) from-value
-
- fn kind-from-digest (digest)
- (((digest @ 3) >> 60) & 0xf:u64) as i32 as Kind
-
- fn uhash (self)
- let ptr = (topointer self)
- let kind = ('kind self)
- let digest =
- switch kind
- case Kind.Number
- copy ((bitcast ptr UNumber) . id)
- pass Kind.Symbol
- pass Kind.String
- do
- copy ((bitcast ptr UString) . id)
- case Kind.TableLimb
- copy ((bitcast ptr UTableLimb) . id)
- case Kind.Table
- copy ((bitcast ptr UTable) . id)
- default
- nullof SHA256.DigestType
- # embed kind bits into most significant bits of digest
- let kindmask = (0xf:u64 << 60)
- let kindbits = (kind as integer as u64 << 60)
- insertvalue digest
- ((digest @ 3) & (~ kindmask)) | kindbits
- 3
-
- fn hashbits (self)
- local digest = (uhash self)
- static-assert ((sizeof digest) == (sizeof u256))
- @ (bitcast &digest @u256)
+using import tukan.uvm
+using import tukan.module
+using import tukan.pickle
- inline hash-from-digest (digest)
- (digest @ 3) as u64 as hash
-
- fn __hash (self)
- hash-from-digest ('uhash self)
-
- @@ memo
- inline __== (cls T)
- static-if (cls == T)
- inline (self other)
- ('uhash self) == ('uhash other)
- elseif (T == SHA256.DigestType)
- inline (self other)
- ('uhash self) == other
-
- spice __dispatch (self handlers...)
- let ptr = `(topointer self)
- let tag = `('kind self)
- let sw = (sc_switch_new tag)
- for arg in ('args handlers...)
- let anchor = ('anchor arg)
- let key arg = ('dekey arg)
- if (key == unnamed)
- sc_switch_append_default sw `(arg)
- else
- let lit = ('@ Kind key)
- let val = (lit as Kind)
- inline append-case (...)
- sc_switch_append_case sw lit ('tag `(arg ...) anchor)
- switch val
- case Kind.Number
- append-case `((bitcast ptr UNumber) . data)
- pass Kind.String
- pass Kind.Symbol
- do
- append-case `((bitcast ptr UString) . data)
- case Kind.TableLimb
- append-case `((bitcast ptr UTableLimb) . data)
- case Kind.Table
- append-case `((bitcast ptr UTable) . data)
- default
- append-case;
- spice-quote
- do ptr
- sw
-
- @@ spice-quote
- fn __repr (self)
- .. "(UAtom "
- dispatch self
- case None () "none"
- case False () "false"
- case True () "true"
- case Number (n) (repr n)
- case String (n) (repr (n as string))
- case Symbol (n) (n as string)
- case TableLimb (n)
- local digest = ('uhash self)
- ..
- tostring ('kind self)
- " "
- (sha256-digest-string digest) as string
- case Table (n)
- local digest = ('uhash self)
- ..
- tostring ('kind self)
- " "
- (sha256-digest-string digest) as string
- default "?"
- ")"
-
- fn tostring (self)
- #returning String
-
- let uatom-repr = this-function
-
- dispatch self
- case None () "none"
- return (String (default-styler style-number "none"))
- case False () "false"
- return (String (default-styler style-number "false"))
- case True () "true"
- return (String (default-styler style-number "true"))
- case Number (num)
- let str = (('tostring num) as string)
- return
- String (default-styler style-number str)
- case String (str)
- let str = (str as string)
- String
- repr str
- case Symbol (str)
- let str = (Symbol (str as string))
- String
- repr str
- case Table (table)
- local str : String
- 'append str "("
- let f =
- Table.gen-each-index
- inline (index node str count)
- if (count > 0)
- 'append str " "
- let strval = (uatom-repr node)
- if (count != index)
- 'append str "(: "
- 'append str
- default-styler style-number (tostring index)
- 'append str " "
- 'append str strval
- 'append str ")"
- else
- 'append str strval
- count += 1
- local count = 0
- f table str count
- let f =
- Table.gen-each-pair
- inline (key value str count)
- if (count > 0)
- 'append str " "
- 'append str "(: "
- 'append str (uatom-repr key)
- 'append str " "
- 'append str (uatom-repr value)
- 'append str ")"
- count += 1
- f table str count
- 'append str ")"
- deref str
- default
- String
- repr self
-
- fn __copy (self)
- viewing self
- let ptr = (topointer self)
- if (ptr != null)
- wrap (copy (bitcast ptr (Rc voidstar))) ('kind self)
- else
- deref (dupe self)
-
- fn __drop (self)
- viewing self
- returning void
- let ptr = (topointer self)
- switch ('kind self)
- case Kind.Number
- __drop (bitcast ptr UNumber)
- pass Kind.Symbol
- pass Kind.String
- do
- __drop (bitcast ptr UString)
- case Kind.TableLimb
- __drop (bitcast ptr UTableLimb)
- case Kind.Table
- __drop (bitcast ptr UTable)
- default;
-
- fn none? (self)
- ('kind self) == Kind.None
-
-run-stage;
-
-sugar uquote (expr...)
- qq [UAtom.from-value] ([sugar-quote] (unquote-splice expr...))
-
-# Evaluation
-################################################################################
-
-let builtins global-env =
- fold (scope env = (Scope) (Table)) for name in
- sugar-quote + - * / let fn quote set get nextindex _
- sym := (UAtom (name as Symbol))
- code := ('hashbits sym)
- _
- 'bind scope name `code
- 'set env sym sym
-
-global global-env : UAtom = global-env
-
-run-stage;
-
-global mt_closure : UAtom =
- Table.new
- type = "closure"
-
-fn global-environment ()
- global-env
-
-fn... ueval (env : UAtom, expr : UAtom)
- let ueval = this-function
-
- assert (('kind env) == UAtom.Kind.Table)
- let envtable = (env as Table)
- switch ('kind expr)
- case UAtom.Kind.Symbol
- return ('get envtable expr)
- case UAtom.Kind.Table
- let head =
- ueval env ('get-index (expr as Table) 0)
- switch ('kind head)
- case UAtom.Kind.Symbol
- let args = (expr as Table)
-
- switch ('hashbits head)
- # (let (: k v) ... expr)
- case builtins.let
- let f =
- Table.gen-each-pair
- inline (k v origenv env)
- env =
- 'set env (copy k)
- ueval origenv (copy v)
- ;
- local newenv = (copy (env as Table))
- f args env newenv
- return (ueval newenv ('get args 1))
- # (fn (param ...) expr)
- case builtins.fn
- return
- UAtom
- 'set-meta
- Table.new (copy env) (copy expr)
- copy mt_closure
- # (quote value)
- case builtins.quote
- return ('get-index args 1)
- default;
- default;
-
- # evaluate all table elements
- let args =
- do
- local args = (Table)
- let table = (expr as Table)
- call
- Table.gen-each-index
- inline (index node result env)
- if (index > 0)
- result =
- 'set-index result (index - 1) (ueval env node)
- \ table args env
- call
- Table.gen-each-pair
- inline (key value result env)
- result =
- 'set result
- if (('kind key) == UAtom.Kind.Symbol) (copy key)
- else (ueval env key)
- ueval env value
- \ table args env
- deref args
-
- switch ('kind head)
- case UAtom.Kind.Table
- let headtable = (head as Table)
- if (('get-meta headtable) == mt_closure)
- let origenv = env
- local env = (copy (('get-index headtable 0) as Table))
- let f = ('get-index headtable 1)
- let ftable = (f as Table)
- let params = ('get-index ftable 1)
- let tparams = (params as Table)
- let eachf =
- Table.gen-each-index
- inline (i name origenv env args)
- let value = ('get-index args i)
- env =
- 'set env name
- if ('none? value)
- 'get args name
- else value
- ;
- eachf tparams origenv env (args as Table)
- let expr = ('get-index ftable 2)
- return (ueval env expr)
- else
- print "cannot apply table:" ('tostring expr)
- return (UAtom)
- case UAtom.Kind.Symbol
- let table = (expr as Table)
-
- fn verify (val K)
- if (('kind val) != K)
- print K "expected, got" ('tostring val)
- fn verify-bool (val)
- switch ('kind val)
- pass UAtom.Kind.False
- pass UAtom.Kind.True
- do;
- default
- print "boolean expected, got" ('tostring val)
-
- inline binop (f)
- let a = ('get-index args 0)
- verify a UAtom.Kind.Number
- let b = ('get-index args 1)
- verify b UAtom.Kind.Number
- return (UAtom (f (a as Number) (b as Number)))
-
- inline eval-set ()
- let source = ('get-index args 0)
- verify source UAtom.Kind.Table
- source as:= Table
- let key = ('get-index args 1)
- let value = ('get-index args 2)
- UAtom ('set source key value)
-
- inline eval-get ()
- let source = ('get-index args 0)
- verify source UAtom.Kind.Table
- source as:= Table
- let key = ('get-index args 1)
- let value = ('get-index args 2)
- let result = ('get source key)
- if ('none? result)
- value
- else
- result
-
- inline eval-countof ()
- let source = ('get-index args 0)
- verify source UAtom.Kind.Table
- source as:= Table
- UAtom ('next-index source)
-
- switch ('hashbits head)
- case builtins.+ (binop +)
- case builtins.- (binop -)
- case builtins.* (binop *)
- case builtins./ (binop /)
- # (set table key value)
- case builtins.set (eval-set)
- # (get table key default)
- case builtins.get (eval-get)
- # (countof table)
- case builtins.nextindex (eval-countof)
- case builtins._
- return (UAtom args)
- default
- print "syntax error:" ('tostring expr)
- return (UAtom)
- default
- print "cannot apply:" ('tostring expr)
- return (UAtom)
- default
- return (copy expr)
-
-# Serialization
-################################################################################
-
-let filewriter =
- inline (data size file lut lutsize)
- let ok? =
- 'write file data size
- assert ok? "write failed"
-
-let hashfilewriter =
- inline (data size file lut lutsize)
- let ok? =
- do
- assert (size == (sizeof SHA256.DigestType))
- let key = (@ (bitcast data @u256))
- local index : u32 =
- do
- try (copy ('get lut key))
- else
- report "filewriter: LUT lookup error: " key
- 0:u32
- 'write file &index (sizeof index)
- assert ok? "hash write failed"
-
-let filereader =
- inline (data size file lut lutsize)
- let ok? =
- 'read file data size
- assert ok? "read failed"
-
-let hashfilereader =
- inline (data size file lut lutsize)
- let ok? =
- do
- assert (size == (sizeof SHA256.DigestType))
- local index : u32
- let ok? = ('read file &index (sizeof index))
- try
- (@ (bitcast data (mutable @u256))) = ('get lut index)
- ok?
- else
- report "filereader: LUT lookup error"
- false
- assert ok? "hash read failed"
-
-fn... pickle1 (file, lut, lutsize, value : UAtom)
- #local digest : SHA256.DigestType = ('uhash value)
- #hashfilewriter (&digest as rawstring) (sizeof digest) file lut lutsize true
- local kind : u8 = (('kind value) as integer as u8)
- filewriter &kind (sizeof kind) file lut lutsize
-
- inline pickle-str (str)
- let sz = (countof str)
- local size : u64 = sz
- filewriter (&size as rawstring) (sizeof size) file lut lutsize
- filewriter (str as rawstring) sz file lut lutsize
-
- dispatch value
- case Number (num)
- (Number.writer filewriter) num file lut lutsize
- case String (str)
- pickle-str str
- case Symbol (str)
- pickle-str str
- case TableLimb (limb)
- (TableLimb.writer filewriter hashfilewriter) limb file lut lutsize
- case Table (table)
- (Table.writer filewriter hashfilewriter) table file lut lutsize
- default;
-
-fn unpickle1 (file lut lutsize cache)
- #local digest : SHA256.DigestType
- #hashfilereader (&digest as rawstring) (sizeof digest) file lut lutsize true
- local kind : u8
- filereader &kind (sizeof kind) file lut lutsize
-
- inline unpickle-str ()
- local size : u64
- filereader (&size as rawstring) (sizeof size) file lut lutsize
- let sz = (deref size)
- local str = (String sz)
- 'resize str sz
- filereader (str as rawstring) sz file lut lutsize
- str
-
- #let kind = (UAtom.kind-from-digest digest)
- let kind = (kind as i32 as UAtom.Kind)
- let atom =
- switch kind
- case UAtom.Kind.None (UAtom)
- case UAtom.Kind.False (UAtom false)
- case UAtom.Kind.True (UAtom true)
- case UAtom.Kind.Number
- local num = ((Number.reader filereader) file lut lutsize)
- UAtom num
- case UAtom.Kind.String
- UAtom (unpickle-str)
- case UAtom.Kind.Symbol
- UAtom.wrap (UString (unpickle-str)) kind
- case UAtom.Kind.TableLimb
- UAtom ((TableLimb.reader filereader hashfilereader) cache file lut lutsize)
- case UAtom.Kind.Table
- UAtom ((Table.reader filereader hashfilereader) cache file lut lutsize)
- default
- assert false "unhandled atom kind"
- unreachable;
- #assert (atom == digest)
- atom
-
-fn... pickle (file, root : UAtom)
- local done : (Set UAtom)
- local lutsize : u32 = 0
- local lut : (Map u256 u32)
- va-map
- inline (value)
- local key = ('hashbits value)
- #report "preset LUT:" key lutsize
- 'set lut key lutsize
- lutsize += 1
- 'insert done value
- UAtom;
- UAtom false
- UAtom true
- fn recur (value ...)
- let file done lut lutsize = ...
- let recur = this-function
- if ('in? done value)
- return;
- 'insert done (copy value)
- assert ('in? done value)
- dispatch value
- case TableLimb (limb)
- for value in limb.cells
- recur value ...
- case Table (table)
- recur table.meta ...
- recur table.ivalues ...
- recur table.keys ...
- recur table.values ...
- default;
- #report "pickling" ('tostring value)
- pickle1 file lut lutsize value
- local key = ('hashbits value)
- #report "set LUT:" key lutsize
- 'set lut key lutsize
- lutsize += 1
- ;
- recur root file done lut lutsize
-
-fn unpickle (file)
- let cur = ('tell file)
- 'seek file (end = 0)
- let size = ('tell file)
- 'seek file cur
- local cache :
- Set UAtom
- inline (value)
- static-if ((typeof value) == SHA256.DigestType)
- UAtom.hash-from-digest value
- else
- hash value
- local lut : (Map u32 u256)
- local lutsize : u32
- va-map
- inline (value)
- local key = ('hashbits value)
- #report "preset LUT:" key lutsize
- 'set lut lutsize key
- lutsize += 1
- 'insert cache value
- UAtom;
- UAtom false
- UAtom true
- loop (root = (unpickle1 file lut lutsize cache))
- local key = ('hashbits root)
- #report "set LUT:" key lutsize
- 'set lut lutsize key
- lutsize += 1
- #report "unpickled" ('tostring root)
- 'insert cache (copy root)
- if (('tell file) >= size)
- break root
- let atom = (unpickle1 file lut lutsize cache)
- atom
-
-# module serialization
-###############################################################################
-
-let
- DB_ALIGNMENT = 8:u32
-
-inline align-size (offset align)
- (offset + align - 1) & (~ (align - 1))
-
-let db = (import tukan.db)
-
-enum ModuleError
- error : Error
- database : db.Error
-
- #inline handle (self)
- fprintf (stderr) "DB error: %s\n" (mdb_strerror (storagecast self))
- abort;
-
- @@ memo
- inline __ras (T cls)
- static-if (T == db.Error)
- fn (self)
- this-type.database self
- elseif (T == Error)
- fn (self)
- this-type.error self
-
- @@ memo
- inline __as (cls T)
- static-if (T == Error)
- fn (self)
- dispatch self
- case error (err)
- copy err
- case database (err)
- err as Error
- default
- sc_error_new (repr self)
-
-let
- DBI_BLOB = "blob"
- #DBI_HASH = "hash"
-
- MAX_DBS = 4
-
-fn... format-hex-memory
-case (inbytes : rawstring, sz : usize)
- let sz2 = (sz * 2)
- let str = (alloca-array i8 sz2)
- inline conv (x)
- (+ x (? (x < 10:u8) 48:u8 87:u8)) as i8
- for i in (range sz)
- c := ((deref (inbytes @ i)) as u8)
- i := i << 1
- str @ i = (conv ((c >> 4:u8) & 0xf:u8))
- str @ (i + 1) = (conv (c & 0xf:u8))
- string str sz2
-case (value : db.Value)
- let sz ptr = (unpack value)
- this-function (ptr as rawstring) sz
-
-struct Databases plain
- blob : db.Index
- #hash : db.Index
-
-type Act < Struct
-
-struct ViewAct < Act
- _txn : db.Transaction
- _db : Databases
-
- inline __typecall (cls txn db)
- super-type.__typecall cls
- _txn = txn
- _db = db
-
- inline __drop (self)
- 'abort self._txn
-
- inline abort (self)
- 'abort self._txn
- lose self
-
- inline commit (self)
- 'abort self._txn
- lose self
-
-struct EditAct < Act
- _txn : db.Transaction
- _db : Databases
-
- inline __typecall (cls txn db)
- super-type.__typecall cls
- _txn = txn
- _db = db
-
- inline __drop (self)
- 'abort self._txn
-
- inline abort (self)
- 'abort self._txn
- lose self
-
- inline commit (self)
- try
- 'commit self._txn
- except (err)
- raise (err as ModuleError)
- lose self
-
-struct Module
- _env : db.Environment
- _db : Databases
-
- fn from-path (path)
- let env =
- try (db.Environment)
- except (err)
- raise (err as ModuleError)
- try
- 'set-maxdbs env MAX_DBS
- 'open env path db.NoSubDir
- let txn = ('begin env)
- try
- let dbi_blob =
- 'open txn DBI_BLOB db.Create
- #let dbi_hash =
- 'open txn DBI_HASH db.Create
- 'commit txn
- return
- super-type.__typecall this-type
- _env = env
- _db =
- Databases
- blob = dbi_blob
- #hash = dbi_hash
- #edge = dbi_edge
- except (err)
- 'abort txn
- raise err
- except (err)
- 'close env
- raise (err as ModuleError)
-
- inline __typecall (cls path)
- from-path path
-
- inline view (self)
- let txn =
- try ('begin self._env db.ReadOnly)
- except (err) (raise (err as ModuleError))
- ViewAct txn self._db
-
- inline edit (self)
- let txn =
- try ('begin self._env)
- except (err) (raise (err as ModuleError))
- EditAct txn self._db
-
- inline __drop (self)
- 'close self._env
-
-# declare void @llvm.memcpy.p0i8.p0i8.i64(i8* <dest>, i8* <src>,
- i64 <len>, i1 <isvolatile>)
-let llvm.memcpy.p0i8.p0i8.i64 =
- extern 'llvm.memcpy.p0i8.p0i8.i64
- function void (mutable rawstring) rawstring usize bool
-
-let stringreader =
- inline (data size source offset contentsize act cache)
- assert ((offset + size) <= contentsize) "buffer underflow"
- llvm.memcpy.p0i8.p0i8.i64 (data as (mutable rawstring))
- & (source @ offset)
- size
- false
- offset += size
-
-let hashstringreader =
- inline (data size source offset contentsize act cache)
- raising (uniqueof ModuleError -1)
- assert ((offset + size) <= contentsize) "buffer underflow"
- llvm.memcpy.p0i8.p0i8.i64 (data as (mutable rawstring))
- & (source @ offset)
- size
- false
- offset += size
- let digest = (@ (data as @SHA256.DigestType))
- if ('in? cache digest)
- return;
- # load recursively
- let key = (db.Value size data)
- 'insert cache ('load1 act key cache)
- ;
-
-let stringwriter =
- inline (data size dest)
- 'append dest (String (data as rawstring) size)
-
-inline dbkey (value)
- local digest = ('uhash value)
- let digestsize = (sizeof digest)
- static-assert ((digestsize % DB_ALIGNMENT) == 0)
- db.Value digestsize &digest
-
-type+ Act
- fn... load1 (self, key : db.Value, cache)
- returning (uniqueof UAtom -1)
- raising (uniqueof ModuleError -1)
- let db_blob = self._db.blob
-
- let content =
- try ('get self._txn self._db.blob key)
- except (err) (raise (err as ModuleError))
-
- let contentsize source = (unpack content)
- let source = (source as rawstring)
- local offset : usize = 0
-
- let ctx... = source offset contentsize self cache
-
- #local digest : SHA256.DigestType
- #hashfilereader (&digest as rawstring) (sizeof digest) file lut lutsize true
- local kind : u8
- stringreader &kind (sizeof kind) ctx...
-
- inline unpickle-str ()
- local size : u64
- stringreader (&size as rawstring) (sizeof size) ctx...
- let sz = (deref size)
- local str = (String sz)
- 'resize str sz
- stringreader (str as rawstring) sz ctx...
- str
-
- #let kind = (UAtom.kind-from-digest digest)
- let kind = (kind as i32 as UAtom.Kind)
- let atom =
- switch kind
- case UAtom.Kind.None (UAtom)
- case UAtom.Kind.False (UAtom false)
- case UAtom.Kind.True (UAtom true)
- case UAtom.Kind.Number
- local num = ((Number.reader stringreader) ctx...)
- UAtom num
- case UAtom.Kind.String
- UAtom (unpickle-str)
- case UAtom.Kind.Symbol
- UAtom.wrap (UString (unpickle-str)) kind
- case UAtom.Kind.TableLimb
- UAtom ((TableLimb.reader stringreader hashstringreader) cache ctx...)
- case UAtom.Kind.Table
- UAtom ((Table.reader stringreader hashstringreader) cache ctx...)
- default
- assert false "unhandled atom kind"
- unreachable;
- #assert (atom == digest)
- atom
-
- fn load (self)
- let key = (dbkey (UAtom))
- let content =
- try ('get self._txn self._db.blob key)
- except (err) (raise (err as ModuleError))
- let digestsize digest = (unpack content)
- assert (digestsize == (sizeof SHA256.DigestType))
-
- local cache :
- Set UAtom
- inline (value)
- static-if ((typeof value) == SHA256.DigestType)
- UAtom.hash-from-digest value
- else
- hash value
- va-map
- inline (value)
- 'insert cache value
- UAtom;
- UAtom false
- UAtom true
-
- load1 self content cache
-
- #loop (root = (unpickle1 file lut lutsize cache))
- local key = ('hashbits root)
- #report "set LUT:" key lutsize
- 'set lut lutsize key
- lutsize += 1
- #report "unpickled" ('tostring root)
- 'insert cache (copy root)
- if (('tell file) >= size)
- break root
- let atom = (unpickle1 file lut lutsize cache)
- atom
-
-#
- fn... id-from-digest-key (act, key : db.Value)
- try
- # if this passes, it already exists
- deref (('get act._txn act._db.hash key) as u64)
- except (err)
- if (err == db.NotFound)
- 0:u64
- else
- raise (err as ModuleError)
-
- fn... digest-id (act, digest : Digest)
- Id.wrap (id-from-digest-key act (digest as db.Value))
-
- fn... load-edge (act, edge : Edge)
- local edge = edge
- let key = (db.Value ((sizeof TypedId) * 2) &edge.tail)
- let content =
- try ('get act._txn act._db.edge key)
- except (err) (raise (err as ModuleError))
- let contentsz source = (unpack content)
- assert (contentsz == (sizeof TypedId))
- source := (bitcast source @TypedId)
- return (deref @source)
-
- fn... load-blob (act, id : Id)
- id := (imply (storagecast id) u64)
- let content =
- try ('get act._txn act._db.blob (id as db.Value))
- except (err) (raise (err as ModuleError))
- let contentsz source = (unpack content)
- source := (bitcast source (mutable @u64))
- sz := @source
- source := (& (source @ 1))
- source := (bitcast source (mutable rawstring))
- Blob sz source
-
-type+ EditAct
- fn... store1 (self, key : db.Value, value : UAtom)
- let db_blob = self._db.blob
-
- local blob : String
-
- #local digest : SHA256.DigestType = ('uhash value)
- #hashfilewriter (&digest as rawstring) (sizeof digest) file lut lutsize true
- local kind : u8 = (('kind value) as integer as u8)
- stringwriter &kind (sizeof kind) blob
-
- inline pickle-str (str)
- let sz = (countof str)
- local size : u64 = sz
- stringwriter (&size as rawstring) (sizeof size) blob
- stringwriter (str as rawstring) sz blob
-
- dispatch value
- case Number (num)
- (Number.writer stringwriter) num blob
- case String (str)
- pickle-str str
- case Symbol (str)
- pickle-str str
- case TableLimb (limb)
- (TableLimb.writer stringwriter stringwriter) limb blob
- case Table (table)
- (Table.writer stringwriter stringwriter) table blob
- default;
-
- let PADSTR = "\0\0\0\0\0\0\0\0"
- #static-assert ((countof PADSTR) == DB_ALIGNMENT)
- 'append blob PADSTR
- let value = (db.Value (align-size (countof blob) DB_ALIGNMENT) (& (blob @ 0)))
- try ('put self._txn db_blob key value)
- except (err) (raise (err as ModuleError))
- ;
-
- fn... store (self, root : UAtom, root? : bool = true)
- local done : (Set UAtom)
- va-map
- inline (value)
- local key = ('hashbits value)
- 'insert done value
- UAtom;
- UAtom false
- UAtom true
-
- fn recur (value ...)
- let self done = ...
- let recur = this-function
- if ('in? done value)
- return;
- 'insert done (copy value)
-
- let key = (dbkey value)
- let db_blob = self._db.blob
- try
- # if this passes, the key already exists
- 'get self._txn db_blob key
- return;
- except (err)
- if (err != db.NotFound)
- raise (err as ModuleError)
-
- assert ('in? done value)
- dispatch value
- case TableLimb (limb)
- for value in limb.cells
- recur value ...
- case Table (table)
- recur table.meta ...
- recur table.ivalues ...
- recur table.keys ...
- recur table.values ...
- default;
- 'store1 self key value
- ;
- recur root self done
- if root?
- let key = (dbkey (UAtom))
- let value = (dbkey root)
- try ('put self._txn self._db.blob key value)
- except (err) (raise (err as ModuleError))
-
- #fn... store-edge (act, edge : Edge)
- local edge = edge
- let key = (db.Value ((sizeof TypedId) * 2) &edge.tail)
- let value = (db.Value (sizeof TypedId) &edge.head)
- try ('put act._txn act._db.edge key value)
- except (err) (raise (err as ModuleError))
- return;
-
- #fn... store-blob (act, blob : Blob)
- let sz = blob.size
- let data = blob.data
- key := blob.digest as db.Value
- let id = ('id-from-digest-key act key)
- if (id != 0:u64)
- return (Id.wrap id)
- try
- # need to commit a new chunk
- let cur = (db.Cursor act._txn act._db.hash)
- defer (inline () ('close cur))
- try
- # it's possible someone else has since added this blob
- let k v = ('get cur key db.SetKey)
- id := (deref (v as u64))
- return (Id.wrap id)
- except (err)
- if (err != db.NotFound)
- raise err
- # they have not - do the hard work now
- # step 1: allocate a new id
- let blob_cur = (db.Cursor act._txn act._db.blob)
- defer (inline () ('close blob_cur))
- term_id := -1:u64 as db.Value
- let highest_id =
- try
- 'get blob_cur term_id db.SetRange
- let k v = ('get blob_cur db.Prev)
- deref (k as u64)
- except (err)
- if (err != db.NotFound)
- raise err
- 'put blob_cur term_id (db.Value)
- 0:u64
- id := (highest_id + 1)
- let id_key = (db.Value id)
- do
- # step 2: map id to content, map hash to id
- the first qword of content is its actual size
- every blob is zero terminated
- let alignedsz = (align-size (sz + 1) DB_ALIGNMENT)
- local content = (db.Value (alignedsz + (sizeof u64)) null)
- 'put blob_cur id_key content db.Reserve
- let targetsize target = (unpack content)
- target := (bitcast target (mutable @u64))
- @target = sz
- target := (& (target @ 1))
- target := (bitcast target (mutable rawstring))
- assert ((ptrtoint target usize) % DB_ALIGNMENT == 0)
- memcpy target data sz
- memset (& (target @ sz)) 0 (alignedsz - sz)
- 'put act._txn act._db.hash key id_key
- return (Id.wrap id)
- except (err)
- raise (err as ModuleError)
-
-###############################################################################
-
-#fn from-value (value)
- do
- return (UNumber value)
-
-#
- match T
- case string
- return (value as string as UAtom)
- default (UAtom)
+##############################################################################
fn testfunc ()
#print ("test" as UAtom)