753b8bc23d7d — Leonard Ritter a month ago
* UVM2: tuple implementation
2 files changed, 441 insertions(+), 0 deletions(-)

M lib/tukan/ustore.sc
A => testing/test_uvm2.sc
M lib/tukan/ustore.sc +1 -0
@@ 26,6 26,7 @@ enum URefKind : u32
     Number = 3 # sign, expn, len, bits...
     Table = 4
     TableLimb = 5
+    Tuple = 6
 
 struct URef plain
     Hasher := SHA224

          
A => testing/test_uvm2.sc +440 -0
@@ 0,0 1,440 @@ 
+using import struct
+using import enum
+using import Map
+using import Array
+using import String
+
+import ..lib.tukan.use
+using import tukan.ustore
+using import tukan.libbf
+
+#
+    new idea for VM:
+    number = fp128
+    tuple as basic composite
+
+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
+global bf_ctx : bf_context_t
+bf_context_init &bf_ctx urealloc null
+
+struct Number plain
+    sign : i64
+    expn : i64
+    len : u64
+    tab : (array u64)
+
+    let DEFAULT_PREC = 56
+
+    fn... from_bf (n : &bf_t)
+        bufsize := (sizeof this-type) + (sizeof u64) * n.len
+        let buf =
+            ptrtoref
+                bitcast
+                    alloca-array u8 bufsize
+                    mutable pointer this-type
+        buf.sign = n.sign
+        buf.expn = n.expn
+        buf.len = n.len
+        for i in (range n.len)
+            buf.tab @ i = n.tab @ i
+        local uref = (URef.store &buf bufsize)
+        uref.kind = URef.Kind.Number
+        uref
+
+fn bftostr (x)
+    local sz : u64
+    let s =
+        bf_ftoa &sz x 10 Number.DEFAULT_PREC BF_FTOA_FORMAT_FREE_MIN
+    String s sz
+
+fn bftosstr (x)
+    local sz : u64
+    let s =
+        bf_ftoa &sz x 10 Number.DEFAULT_PREC BF_FTOA_FORMAT_FREE_MIN
+    string s sz
+
+fn numbertobf (r ref)
+    let num =
+        bitcast ('load ref) (pointer Number)
+    local n =
+        bf_t
+            sign = (num.sign as i32)
+            expn = num.expn
+            len = num.len
+            tab = (bitcast (& (num.tab @ 0)) (mutable pointer u64))
+    bf_set r &n
+
+fn numbertostr (ref)
+    local n : bf_t
+    bf_init &bf_ctx &n
+    numbertobf &n ref
+    let str = (bftostr &n)
+    bf_delete &n
+    str
+
+fn numbertosstr (ref)
+    local n : bf_t
+    bf_init &bf_ctx &n
+    numbertobf &n ref
+    let str = (bftosstr &n)
+    bf_delete &n
+    str
+
+inline gen-number (f value)
+    local n : bf_t
+    bf_init &bf_ctx &n
+    f &n value
+    let uref = (Number.from_bf n)
+    bf_delete &n
+    uref
+
+fn... number (value : i64)
+    gen-number bf_set_si value
+case (value : u64)
+    gen-number bf_set_ui value
+case (value : f64)
+    gen-number bf_set_float64 value
+
+inline number_op0_inplace (f ...)
+    fn (x)
+        local res : bf_t
+        bf_init &bf_ctx &res
+        numbertobf &res x
+        f &res ...
+        let result = (Number.from_bf res)
+        bf_delete &res
+        result
+
+inline number_op0 (f ...)
+    fn ()
+        local res : bf_t
+        bf_init &bf_ctx &res
+        f &res ...
+        let result = (Number.from_bf res)
+        bf_delete &res
+        result
+
+inline number_op1 (f ...)
+    fn (x)
+        local bfx : bf_t
+        bf_init &bf_ctx &bfx
+        numbertobf &bfx x
+        local res : bf_t
+        bf_init &bf_ctx &res
+        f &res &bfx ...
+        let result = (Number.from_bf res)
+        bf_delete &bfx
+        bf_delete &res
+        result
+
+inline number_op2 (f ...)
+    fn (a b)
+        local bfa : bf_t
+        local bfb : bf_t
+        bf_init &bf_ctx &bfa
+        bf_init &bf_ctx &bfb
+        numbertobf &bfa a
+        numbertobf &bfb b
+        local res : bf_t
+        bf_init &bf_ctx &res
+        f &res &bfa &bfb ...
+        let result = (Number.from_bf res)
+        bf_delete &bfa
+        bf_delete &bfb
+        bf_delete &res
+        result
+
+fn number-cmp (a b)
+    local bfa : bf_t
+    local bfb : bf_t
+    bf_init &bf_ctx &bfa
+    bf_init &bf_ctx &bfb
+    numbertobf &bfa a
+    numbertobf &bfb b
+    let result = (bf_cmp &bfa &bfb)
+    bf_delete bfa
+    bf_delete bfb
+    result
+
+let number-const-log2 = (number_op0 bf_const_log2 Number.DEFAULT_PREC 0)
+let number-const-pi = (number_op0 bf_const_pi Number.DEFAULT_PREC 0)
+
+let number-toint = (number_op0_inplace bf_rint bf_rnd_t.BF_RNDZ)
+let number-neg = (number_op0_inplace bf_neg)
+
+let number-add = (number_op2 bf_add Number.DEFAULT_PREC 0)
+let number-sub = (number_op2 bf_sub Number.DEFAULT_PREC 0)
+let number-mul = (number_op2 bf_mul Number.DEFAULT_PREC 0)
+let number-div = (number_op2 bf_div Number.DEFAULT_PREC 0)
+let number-rem = (number_op2 bf_rem Number.DEFAULT_PREC 0 bf_rnd_t.BF_RNDZ)
+
+let number-pow = (number_op2 bf_pow Number.DEFAULT_PREC 0)
+let number-atan2 = (number_op2 bf_atan2 Number.DEFAULT_PREC 0)
+
+let number-or = (number_op2 bf_logic_or)
+let number-xor = (number_op2 bf_logic_xor)
+let number-and = (number_op2 bf_logic_and)
+
+let number-sqrt = (number_op1 bf_sqrt Number.DEFAULT_PREC 0)
+let number-exp = (number_op1 bf_exp Number.DEFAULT_PREC 0)
+let number-log = (number_op1 bf_log Number.DEFAULT_PREC 0)
+let number-pow = (number_op1 bf_pow Number.DEFAULT_PREC 0)
+let number-cos = (number_op1 bf_cos Number.DEFAULT_PREC 0)
+let number-sin = (number_op1 bf_sin Number.DEFAULT_PREC 0)
+let number-tan = (number_op1 bf_tan Number.DEFAULT_PREC 0)
+let number-atan = (number_op1 bf_atan Number.DEFAULT_PREC 0)
+let number-asin = (number_op1 bf_asin Number.DEFAULT_PREC 0)
+let number-acos = (number_op1 bf_acos Number.DEFAULT_PREC 0)
+
+fn number-int? (x)
+    (number-cmp x (number-toint x)) == 0
+
+fn number-get-u64 (x)
+    local bfx : bf_t
+    bf_init &bf_ctx &bfx
+    try
+        numbertobf &bfx x
+    else
+        bf_delete &bfx
+        raise;
+
+    local bfcmp : bf_t
+    bf_init &bf_ctx &bfcmp
+    bf_set_zero &bfcmp 0
+    if ((bf_cmp &bfx &bfcmp) >= 0)
+        bf_set_si &bfcmp 0x7fffffffffffffff:i64
+        if ((bf_cmp &bfx &bfcmp) <= 0)
+            local bfint : bf_t
+            bf_init &bf_ctx &bfint
+            bf_set &bfint &bfx
+            bf_rint &bfint bf_rnd_t.BF_RNDZ
+            if ((bf_cmp &bfx &bfint) == 0)
+                local outp : i64
+                bf_get_int64 &outp &bfx 0
+                bf_delete &bfint
+                bf_delete &bfcmp
+                bf_delete &bfx
+                return ((deref outp) as u64)
+            bf_delete &bfint
+    bf_delete &bfcmp
+    bf_delete &bfx
+    raise;
+
+# String
+###############################################################################
+
+inline... ustring (str : string)
+    local uref = (URef.store (str as rawstring) (countof str))
+    uref.kind = URef.Kind.String
+    uref
+
+inline... usymbol (str : string)
+    local uref = (URef.store (str as rawstring) (countof str))
+    uref.kind = URef.Kind.Symbol
+    uref
+
+# Tuple
+###############################################################################
+
+let IndexBits = 4
+let ArrayCellCount = (1 << IndexBits)
+let IndexMask = (ArrayCellCount - 1)
+
+struct UTuple plain
+    cells : (array URef)
+
+    fn unref (uref)
+        let ptr sz = ('load uref)
+        _
+            ptrtoref
+                bitcast ptr (pointer this-type)
+            sz // (sizeof URef)
+
+inline utuple-init (count f)
+    bufsize := (sizeof URef) * count
+    let buf =
+        ptrtoref
+            bitcast
+                alloca-array u8 bufsize
+                mutable pointer UTuple
+    f buf.cells
+    local uref = (URef.store &buf bufsize)
+    uref.kind = URef.Kind.Tuple
+    uref
+
+fn utuple (...)
+    count := (va-countof ...)
+    utuple-init count
+        inline (cells)
+            va-map
+                inline (i)
+                    cells @ i = (va@ i ...)
+                va-range count
+
+###############################################################################
+
+fn uref-repr (value)
+    #returning String
+
+    let uref-repr = this-function
+    if ('null? value)
+        return (String "null")
+
+    switch value.kind
+    case URef.Kind.Number
+        let str = (numbertosstr value)
+        return
+            String (default-styler style-number str)
+    case URef.Kind.String
+        let buf sz = ('load value)
+        let str = (string (buf as rawstring) sz)
+        String
+            repr str
+    case URef.Kind.Symbol
+        let buf sz = ('load value)
+        let str = (Symbol (string (buf as rawstring) sz))
+        String
+            repr str
+    case URef.Kind.Tuple
+        let ut count = (UTuple.unref value)
+        local str : String
+        'append str "("
+        for i in (range count)
+            if (i > 0)
+                'append str " "
+            'append str (uref-repr (ut.cells @ i))
+        'append str ")"
+        deref str
+    default
+        String
+            repr value
+
+###############################################################################
+
+fn translate-quote (value)
+    fn recur (value)
+        returning URef
+        let recur = this-function
+        let T = ('typeof value)
+        match T
+        case list
+            let l = (value as list)
+            let sz = (countof l)
+            return
+                utuple-init sz
+                    inline (cells)
+                        for i elem in (enumerate l)
+                            cells @ i = (recur elem)
+        case string
+            let str = (value as string)
+            return (ustring str)
+        case Symbol
+            let str = (value as Symbol as string)
+            return (usymbol str)
+        default
+            let tk = ('kind ('storageof T))
+            switch tk
+            case type-kind-integer
+                return (number (sc_const_int_extract value))
+            case type-kind-real
+                return (number (sc_const_real_extract value))
+            default;
+            report "unable to handle type" (repr T)
+            error (.. "unable to handle type" (repr T))
+    recur (value as Value)
+
+sugar uquote (expr...)
+    if ((countof expr...) == 1)
+        let at = (decons expr...)
+        translate-quote at
+    else
+        translate-quote expr...
+
+run-stage;
+
+###############################################################################
+
+#fn table-tests ()
+    let t = (table)
+    print "empty table:" t
+    let t =
+        table-set t (ustring "key") (ustring "value")
+    print "after 1 insert:" t
+    table-dump t
+    let t =
+        table-set t (ustring "key2") (ustring "value")
+    print "after 2 insert:" t
+    table-dump t
+    print "get" (table-get t (ustring "key"))
+    let t =
+        table-del t (ustring "key")
+    table-dump t
+    let t =
+        table-del t (ustring "key2")
+    table-dump t
+    print "get" (table-get t (ustring "key"))
+
+fn number-tests ()
+    print
+        number -1
+        number 0
+        number 1
+        number 2
+    print
+        uref-repr (number-const-pi)
+    value :=
+        number-neg
+            number-toint
+                number-sqrt
+                    number-or
+                        number 41
+                        number 10
+    print
+        numbertostr value
+    print
+        number-cmp value (number -6)
+    print (number-int? value)
+
+inline uref-tests ()
+    print (uref-repr (ustring "test"))
+    print (uref-repr (number 3.5))
+    let t =
+        utuple
+            number 23
+            number 42
+            number 303
+    print
+        uref-repr t
+    print
+        uref-repr
+            uquote (test "test" 1 2 3 (a b c) 3.5)
+
+try
+    #table-tests;
+    #number-tests;
+    uref-tests;
+    #uarray-tests;
+#
+    print "final emptied table:" t
+    print
+        ustring "hello"
+else
+    print "failed"
+
+;
  No newline at end of file