39eb89b43298 — Leonard Ritter 30 days ago
* test_uvm3: initial support for LMDB
1 files changed, 618 insertions(+), 72 deletions(-)

M testing/test_uvm3.sc
M testing/test_uvm3.sc +618 -72
@@ 408,6 408,7 @@ struct Table
     @@ memo
     inline reader (f hashf)
         fn read (cache ...)
+            returning (uniqueof this-type -1)
             local memberdigest : SHA256.DigestType
             local table : this-type
             va-map

          
@@ 936,7 937,8 @@ type+ UAtom
                     label done
                         if (('typeof elem) == list)
                             elem as:= list
-                            if ((countof elem) == 3)
+                            let elemsize = (countof elem)
+                            if ((elemsize >= 2) & (elemsize <= 3))
                                 let head key value = (decons elem 3)
                                 if (('typeof head) == Symbol)
                                     head as:= Symbol

          
@@ 945,7 947,11 @@ type+ UAtom
                                     pass ':
                                     do
                                         key := (recur key)
-                                        value := (recur value)
+                                        let value =
+                                            if (elemsize == 3)
+                                                recur value
+                                            else
+                                                UAtom true
                                         merge done
                                             'set t key value
                                     default;

          
@@ 963,6 969,10 @@ type+ UAtom
                 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

          
@@ 1193,7 1203,7 @@ sugar uquote (expr...)
 
 let builtins global-env =
     fold (scope env = (Scope) (Table)) for name in
-        sugar-quote + - * / let fn
+        sugar-quote + - * / let fn quote set get nextindex _
         sym := (UAtom (name as Symbol))
         code := ('hashbits sym)
         _

          
@@ 1220,16 1230,60 @@ fn... ueval (env : UAtom, expr : UAtom)
     case UAtom.Kind.Symbol
         return ('get envtable expr)
     case UAtom.Kind.Table
-        let table = (expr as Table)
-        let head = ('get-index table 0)
         let head =
-            if (('kind head) == UAtom.Kind.Symbol)
-                let result = ('get envtable head)
-                if ('none? result)
-                    print "unknown name: " head
-                result
-            else
-                ueval env 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

          
@@ 1240,19 1294,20 @@ fn... ueval (env : UAtom, expr : UAtom)
                 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 value origenv env params)
-                            if (i > 0)
-                                let name =
-                                    'get-index params (i - 1)
-                                env =
-                                    'set env name
-                                        ueval origenv (copy value)
+                        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 (expr as Table) origenv env (params as Table)
+                eachf tparams origenv env (args as Table)
                 let expr = ('get-index ftable 2)
-                ueval env expr
+                return (ueval env expr)
             else
                 print "cannot apply table:" ('tostring expr)
                 return (UAtom)

          
@@ 1271,37 1326,51 @@ fn... ueval (env : UAtom, expr : UAtom)
                     print "boolean expected, got" ('tostring val)
 
             inline binop (f)
-                let a = (ueval env ('get-index table 1))
+                let a = ('get-index args 0)
                 verify a UAtom.Kind.Number
-                let b = (ueval env ('get-index table 2))
+                let b = ('get-index args 1)
                 verify b UAtom.Kind.Number
                 return (UAtom (f (a as Number) (b as Number)))
 
-            inline eval-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 table env newenv
-                return (ueval newenv ('get table 1))
+            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-fn ()
-                UAtom
-                    'set-meta
-                        Table.new (copy env) (copy expr)
-                        copy mt_closure
+            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 /)
-            case builtins.let (eval-let)
-            case builtins.fn (eval-fn)
+            # (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)

          
@@ 1496,6 1565,487 @@ fn unpickle (file)
         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)

          
@@ 1527,6 2077,7 @@ fn testfunc ()
                 : a 2
                 : b 2.5
                 : c 4
+                : d
                 : make-seq
                     fn (f1 f2)
                         fn (x y z)

          
@@ 1536,37 2087,7 @@ fn testfunc ()
                         * x x
                 let
                     : muladd (make-seq * +)
-                    muladd (pow2 c) b a
-                let
-                    : muladd (make-seq * +)
-                    muladd (pow2 c) b a
-                let
-                    : muladd (make-seq * +)
-                    muladd (pow2 c) b a
-                let
-                    : muladd (make-seq * +)
-                    muladd (pow2 c) b a
-                let
-                    : muladd (make-seq * +)
-                    muladd (pow2 c) b a
-                let
-                    : muladd (make-seq * +)
-                    muladd (pow2 c) b a
-                let
-                    : muladd (make-seq * +)
-                    muladd (pow2 c) b a
-                let
-                    : muladd (make-seq * +)
-                    muladd (pow2 c) b a
-                let
-                    : muladd (make-seq * +)
-                    muladd (pow2 c) b a
-                let
-                    : muladd (make-seq * +)
-                    muladd (pow2 c) b a
-                let
-                    : muladd (make-seq * +)
-                    muladd (pow2 c) b a
+                    muladd (pow2 (: x c)) b a
 
     using import tukan.File
     let testfilepath =

          
@@ 1587,6 2108,29 @@ fn testfunc ()
                         .. "opening " testfilepath " failed"
             unpickle testfile
 
+    let testmodulepath =
+        .. module-dir "/test.um"
+    let expr3 =
+        do
+            try
+                let mod = (Module testmodulepath)
+                report "storing..."
+                let act = ('edit mod)
+                'store act expr
+                'commit act
+            except (err)
+                raise (err as Error)
+
+            try
+                let mod = (Module testmodulepath)
+                report "loading..."
+                let act = ('view mod)
+                'load act
+            except (err)
+                raise (err as Error)
+    print "db load:"
+        'tostring expr3
+
     let env = (global-environment)
     let result1 result2 =
         ueval env expr

          
@@ 1612,6 2156,8 @@ fn testfunc ()
         (('hashbits expr) >> (256 - 4)) as u8
     ;
 
+
+
 do
     #print ("test" as UAtom)