rev: b5263db721ebca6ff9509f69a7255c55f9c956e4 tukan/testing/test_typeschema2.sc -rw-r--r-- 10.5 KiB View raw Log this file
b5263db721eb — Leonard Ritter * initial work on base encoding 26 days ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
#
    do we need a database format?

    our general data model has two parts:

    1. an immutable, conceptually ever-expanding table of data blobs,
        addressable by content (content-addressable store)

        which can be used to implement tries and merkle trees

    2. a mutable entry point into the root data structure

using import struct
using import enum
using import Map
using import Array

# 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

import ..lib.tukan.use
using import tukan.SHA256

struct UPointer plain
    digest : SHA224.DigestType
    head : i32

    inline... to (data : voidstar, size : usize)
        local sha : SHA224
        'hash sha (data as rawstring) size
        local result : this-type
        result.head = -1
        'digest sha result.digest
        result

    inline __hash (self)
        as 
            bor
                (self.digest @ 0) as u64
                ((self.digest @ 1) as u64) << 32
            hash

    fn __repr (self)
        local content = self.digest
        .. "@"
            sha224-digest-string content

    @@ memo
    inline __== (cls T)
        static-if (cls == T)
            inline (a b)
                (storagecast a) == (storagecast b)

    @@ memo
    inline __imply (cls T)
        static-if (T == (storageof cls))
            storagecast

    @@ memo
    inline __rimply (T cls)
        static-if (T == (storageof cls))
            inline (self)
                bitcast self cls

struct UBlob plain
    size : usize
    offset : usize

    fn __repr (self)
        .. "<UBlob["
            dec self.size
            "] @ "
            dec self.offset
            ">"

struct UStore # content addressable store abstraction
    let ChunkType = u64
    let ChunkTypeSize = (sizeof ChunkType)
    
    # root address
    root : UPointer = (undef UPointer)
    # address to offset into memory
    map : (Map UPointer UBlob)
    # memory blob
    memory : (Array ChunkType)

    fn... insert
    case (self, data : voidstar, size : usize)
        let addr = (UPointer.to data size)
        try
            let blob = ('get self.map addr)
            _ addr (copy blob)
        else
            let offset = (countof self.memory)
            numblocks := ((size + ChunkTypeSize - 1) // ChunkTypeSize)
            #'append-slots self.memory numblocks
            #'emplace-append-many self.memory numblocks 0xdeadbeef:u64
            for i in (range numblocks)
                'append self.memory 0xdeadbeef:u64
            ptr := (& (self.memory @ offset))
            llvm.memcpy.p0i8.p0i8.i64
                ptr as (mutable rawstring)
                data as rawstring
                size as i64
                false
            let blob =
                UBlob
                    size = size
                    offset = offset
            'set self.map addr blob
            #do
                ptr := (& (self.memory @ offset))
                let revaddr = (UPointer.to ptr size)
                #assert (addr == revaddr)
            _ addr blob
    case (self, str : string)
        this-function self (str as rawstring) (countof str)
    case (self, data)
        static-assert (not ((storageof data) < pointer))
        let data =
            static-if (&? data) data
            else
                local data = data
        this-function self &data (sizeof data)

    inline... @ (self, addr : UPointer, T : type)
        blob := ('get self.map addr)
        ptr := (& (self.memory @ blob.offset))
        @ (ptr as @T)

global module : UStore

#
    types are schemas which specify the layout of the specified memory as well as
    addressing methods

enum TypeKind : u8
    Unknown = 0
    Integer = 1
    Real = 2
    Ref256 = 3
    Array = 4
    Tuple = 5
    Function = 6
    Qualify = 7
    Typename = 8

inline intern-string (s)
    let addr = ('insert module s)
    global interned-string = addr
    interned-string

print
    UPointer.to ("The quick brown fox jumps over the lazy dog" as rawstring) 0

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

@@ verify-sizeof 16
struct NumberType plain
    kind : TypeKind
    bitcount : i64

fn... number-type (kind : TypeKind, bitcount : i32,)
    _
        'insert module
            NumberType kind bitcount
        ;

inline integer-type (bitcount)
    number-type TypeKind.Integer bitcount

inline real-type (bitcount)
    number-type TypeKind.Real bitcount

inline bitcountof (T)
    try
        let ptr = ('@ module T NumberType)
        deref ptr.bitcount
    else 0:i64

global i32-type = (integer-type 32)
global u32-type = (integer-type 32)
global float-type = (real-type 32)

@@ verify-sizeof 36
struct UPointerType plain
    kind : TypeKind
    element : UPointer

fn... pointer-type (element : UPointer,)
    _
        'insert module
            UPointerType TypeKind.Ref256 element
        ;

@@ verify-sizeof 48
struct ArrayType plain
    kind : TypeKind
    element : UPointer
    count : u64

fn... array-type (element : UPointer, count : u64)
    _
        'insert module
            ArrayType TypeKind.Array element count
        ;

let MaxNodes = 8
struct UPTreeHeader plain
    count : u64
    root : UPointer
    tail : UPointer

struct UPTreeNode plain
    nodes : (array UPointer MaxNodes)

fn empty-uptree ()
    _
        'insert module
            UPTreeHeader 0 (nullof UPointer) (nullof UPointer)
        ;

global empty-uptree = (empty-uptree)

fn insert-uptree (header element...)
    'insert module
        UPTreeNode


print empty-uptree

print
    integer-type 32
    bitcountof
        integer-type 32
print
    pointer-type
        integer-type 32

print
    i32-type
    bitcountof
        integer-type 32
print
    real-type 32

print
    array-type i32-type 16

#
    untyped
    type.typename <module-uri:StringId> <name:StringId> <super-type:TypeId> <storage-type:TypeId> <memoized-value:Any> ...
    OK type.storage.integer <bitcount:i32> (negative bitcount: signed integer)
    OK 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


#
    types:

    bool
    i32
    f32
    tuple T ...
    vector T size
    function <tuple-type> <- <tuple-type>




#fn decode-schemastr (s ofs)
    returning type i32
    if (ofs > (countof s))
        error "schemastr is empty"
    c := s @ ofs
    nextofs := ofs + 1
    switch c
    case (char "b") (_ bool nextofs)
    case (char "c") (_ i8 nextofs)
    case (char "h") (_ i16 nextofs)
    case (char "i") (_ i32 nextofs)
    case (char "l") (_ i64 nextofs)
    case (char "C") (_ u8 nextofs)
    case (char "H") (_ u16 nextofs)
    case (char "I") (_ u32 nextofs)
    case (char "L") (_ u64 nextofs)
    case (char "f") (_ f32 nextofs)
    case (char "d") (_ f64 nextofs)
    case (char "p")
        let T nextofs = (this-function s nextofs)
        _ (pointer.type T) nextofs
    case (char "(")
        local types : (Array type)
        loop (ofs = nextofs)
            c := s @ ofs
            switch c
            case (char ")")
                let firstval = (reftoptr (types @ 0))
                break (sc_tuple_type ((countof types) as i32) firstval) (ofs + 1)
            default
                let T nextofs = (this-function s ofs)
                assert (nextofs != ofs)
                'append types T
                repeat nextofs
    default
        error
            .. "can't parse schemastr: " (repr s)

#fn... from-schemastr (s)
    let T c = (decode-schemastr s 0)
    assert (c == (countof s))
    T


#fn encode-schemastr (stack T)
    returning string
    T := ('storageof T)
    for i elem in (enumerate ('reverse stack))
        if (elem == T)
            if (i > 9)
                error
                    .. "recursion limit reached (" (repr i) ")"
            return
                hex i
    kind := ('kind T)
    let parent = this-function
    inline array-like-type (open-token close-token)
        let size = ('element-count T)
        .. open-token
            parent stack ('element@ T 0)
            hex size
            close-token
    switch kind
    case type-kind-tuple
        'append stack T
        let size = ('element-count T)
        ..
            fold (s = "(") for i in (range size)
                elem := ('element@ T i)
                .. s (this-function stack elem)
            ")"
    case type-kind-array
        array-like-type "[" "]"
    case type-kind-vector
        array-like-type "<" ">"
    case type-kind-integer
        width := ('bitcount T)
        signed := ('signed? T)
        switch width
        case 1 "b"
        case 8 (? signed "c" "C")
        case 16 (? signed "h" "H")
        case 32 (? signed "i" "I")
        case 64 (? signed "l" "L")
        default
            error
                .. "can't handle integer bitcount: " (repr width)
    case type-kind-real
        width := ('bitcount T)
        switch width
        case 32 "f"
        case 64 "d"
        default
            error
                .. "can't handle real bitcount: " (repr width)
    case type-kind-pointer
        .. "p" (this-function stack ('element@ T 0))
    default
        error
            .. "can't handle kind: " (repr kind)

#fn schemastr (T)
    local stack : (Array type)
    encode-schemastr stack T

#do
    let s = "Rosetta code"
    local k = (tupleof 1 2 3)
    let addr =
        'insert module k
    let blob =
        try
            'get module addr
        else
            error "invalid access"
    let ptr = ('@ module blob (tuple i32 i32 i32))
    print ptr
    ;


;