505391425fb2 — Leonard Ritter a month ago
* fixed localstorage for unique values
5 files changed, 584 insertions(+), 30 deletions(-)

M lib/tukan/thread.sc
M testing/test_threading.sc
M testing/test_uvm.sc
M testing/test_uvm2.sc
A => testing/test_uvm3.sc
M lib/tukan/thread.sc +49 -22
@@ 1,5 1,6 @@ 
 using import .sdl
 using import Capture
+using import Rc
 
 let mutable-voidstar = (mutable voidstar)
 

          
@@ 21,34 22,46 @@ typedef LocalStorage
         let T = (typeof self)
         let id = ('id self)
         let ptr = (SDL_TLSGet id)
-        @
-            if (ptr == null)
-                let ptr = (malloc T.ValueType)
-                SDL_TLSSet id (bitcast ptr voidstar)
-                    fn "destructor" (ptr)
-                        __drop (@ (bitcast ptr T.ValuePointerType))
-                        free ptr
-                        ;
-                store T.InitValue ptr
-                ptr
-            else (bitcast ptr T.ValuePointerType)
+        let RcType = (Rc T.ValueType)
+        if (ptr == null)
+            let value = (RcType.wrap (T.InitValue))
+            let value-copy = (copy value)
+            SDL_TLSSet id (bitcast value-copy voidstar)
+                fn "destructor" (ptr)
+                    let self = (bitcast ptr RcType)
+                    drop self
+                    ;
+            value
+        else
+            let value = (bitcast ptr RcType)
+            let value-copy = (copy value)
+            lose value # we maintain our internal reference
+            value-copy
 
     fn id (self)
         storagecast self
 
     @@ spice-cast-macro
     fn __imply (T valueT)
-        inline tovalueref (self) (@ self)
+        inline tovalueref (self) (Rc.view (@ self))
         let T = (('@ (T as type) 'ValueType) as type)
         if (T == valueT) `tovalueref
         else
             `()
 
+    @@ spice-cast-macro
+    inline __= (T valueT)
+        inline assignref (self other)
+            (@ self) = other
+        let T = (('@ (T as type) 'ValueType) as type)
+        if (T == valueT) `assignref
+        else
+            `()
+
     spice __typecall (cls initvalue)
         let cls = (cls as type)
         assert (cls == this-type)
         assert ('constant? initvalue)
-        let ValueType = ('typeof initvalue)
 
         @@ memoize
         fn gen-type (ValueType initvalue)

          
@@ 60,10 73,20 @@ typedef LocalStorage
                     ">"
                 \ < parent-type : SDL_TLSID
                 let ValueType
-                let ValuePointerType = [('mutable (pointer.type ValueType))]
+                #let ValuePointerType = [('mutable (pointer.type ValueType))]
                 let InitValue = initvalue
 
-        let T = (gen-type ValueType initvalue)
+        let T =
+            if (('typeof initvalue) == Closure)
+                let f = (typify (initvalue as Closure))
+                let rtype = ('return-type ('element@ ('typeof f) 0))
+                let ValueType = ('strip-qualifiers rtype)
+                gen-type ValueType f
+            else
+                let ValueType = ('typeof initvalue)
+                gen-type ValueType
+                    spice-quote
+                        fn () initvalue
         `(bitcast (SDL_TLSCreate) T)
 
 #-------------------------------------------------------------------------------

          
@@ 108,19 131,23 @@ typedef+ Thread
                         let ptr = (bitcast arg PT)
                         let f = (deref (@ ptr 0 1))
                         (@ ptr 0 0) = true
+                        let TF = (static-typify ((typeof f) . __call) (qualifiersof f))
                         let result =
-                            try (f)
-                            except (err)
-                                return -1
+                            static-if ((raiseof (typeof TF)) == noreturn) (f)
+                            else
+                                try (f)
+                                else
+                                    return -1
                         let result =
                             if ((typeof result) == i32) result
                             else 0
                         result
                     name
-                    bitcast ptr mutable-voidstar
+                    bitcast (view ptr) mutable-voidstar
             # ensure the stack address has been retrieved before returning
             while ((@ ptr 0 0) != true)
                 SDL_Delay 0
+            lose ptr
             return th
 
         let name =

          
@@ 146,7 173,7 @@ typedef+ Thread
                         name
                         f
 
-        if (T < Capture)
+        if (T < CaptureTemplate)
             return `(from-capture f name)
         `(from-closure f name)
 

          
@@ 163,10 190,10 @@ typedef Mutex :: (mutable pointer SDL_mu
         SDL_DestroyMutex (storagecast self)
 
     inline lock (self)
-        SDL_LockMutex (storagecast self)
+        SDL_LockMutex (storagecast (view self))
 
     inline unlock (self)
-        SDL_UnlockMutex (storagecast self)
+        SDL_UnlockMutex (storagecast (view self))
 
 #-------------------------------------------------------------------------------
 

          
M testing/test_threading.sc +4 -3
@@ 1,5 1,6 @@ 
 
-using import ..tukan.thread
+import ..lib.tukan.use
+using import tukan.thread
 using import Capture
 
 let Threadx64 = (array Thread 64)

          
@@ 7,7 8,7 @@ let Threadx64 = (array Thread 64)
 run-stage;
 
 global tls = (LocalStorage 0)
-print tls (@ tls)
+print tls (@ tls) (tls as i32)
 assert (tls == 0)
 tls = 303
 assert (tls == 303)

          
@@ 22,7 23,7 @@ local threads = (nullof Threadx64)
 for i in (range N)
     threads @ i =
         Thread
-            capture [i x] ()
+            capture () {i x}
                 assert (tls == 0)
                 tls = 42
                 print "thread #" i (active-thread-id)

          
M testing/test_uvm.sc +261 -5
@@ 271,8 271,9 @@ struct TableLimb plain
         uref.kind = URef.Kind.TableLimb
         uref
 
-@@ verify-sizeof 104
+@@ verify-sizeof 136
 struct Table plain
+    meta : URef
     keys : URef
     values : URef
     ivalues : URef

          
@@ 297,7 298,7 @@ fn table-capacity (uarr)
 fn... table-seti (uarr, index : u64, value : URef)
     fn recur (node depth index value)
         returning URef u64
-        raising (uniqueof UError 1)
+        raising (uniqueof UError -1)
 
         if (index == 0)
             # truncate

          
@@ 401,7 402,7 @@ fn... table-geti (uarr, index : u64)
     uarr := (Table.unref uarr)
     fn recur (node depth index)
         returning URef
-        #raising (uniqueof UError 1)
+        raising (uniqueof UError -1)
 
         node := (copy node)
 

          
@@ 522,6 523,16 @@ fn... table-set (table, key : URef, valu
     table.values = values
     'ref table
 
+fn table-getmeta (table)
+    let table = (Table.unref table)
+    copy table.meta
+
+fn table-setmeta (table metatable)
+    assert (metatable.kind == URef.Kind.Table)
+    local table = (Table.unref table)
+    table.meta = metatable
+    'ref table
+
 fn... table-del (table, key : URef)
     label do-regular-del
         if (key.kind == URef.Kind.Number)

          
@@ 616,6 627,47 @@ fn table-dump (table)
     recur "  " table.keys table.values 0
     print;
 
+@@ memo
+inline table-eachi (f)
+    fn process (value ...)
+        fn recur (node depth index ...)
+            returning void
+            if (node.kind == URef.Kind.TableLimb) # branch
+                let limb = (TableLimb.unref node)
+                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
+                        ...
+            elseif (not ('null? node))
+                f index node ...
+                return;
+        table := (Table.unref value)
+        recur table.ivalues table.depth 0:u64 ...
+
+@@ memo
+inline table-each (f)
+    fn process (value ...)
+        fn recur (key value ...)
+            returning void
+            if (key.kind == URef.Kind.TableLimb) # branch
+                let kl = ((TableLimb.unref key) . cells)
+                let vl = ((TableLimb.unref value) . cells)
+                for i in (range ArrayCellCount)
+                    let k v =
+                        kl @ i
+                        vl @ i
+                    this-function k v ...
+            elseif (not ('null? key))
+                f key value ...
+                return;
+        table := (Table.unref value)
+        recur table.keys table.values ...
+
 fn table (...)
     local table : Table
     let t = ('ref table)

          
@@ 707,6 759,186 @@ fn uref-repr (value)
 
 ###############################################################################
 
+let builtins global-env =
+    fold (scope env = (Scope) (table)) for name in
+        sugar-quote + - * / let fn
+        sym := (usymbol (name as Symbol as string))
+        code := sym as integer
+        _
+            'bind scope name `code
+            try
+                table-set env sym sym
+            else
+                error "expanding table failed"
+
+run-stage;
+
+global mt_closure =
+    do
+        try
+            table
+                type = (ustring "closure")
+        else
+            error "defining metatype failed"
+
+fn global-environment ()
+    global-env
+
+fn... ueval (env : URef, expr : URef)
+    let ueval = this-function
+
+    assert (env.kind == URef.Kind.Table)
+    switch expr.kind
+    case URef.Kind.Symbol
+        return (table-get env expr)
+    case URef.Kind.Table
+        let head = (table-geti expr 0)
+        let head =
+            if (head.kind == URef.Kind.Symbol)
+                let result = (table-get env head)
+                if ('null? result)
+                    print "unknown name: " head
+                result
+            else
+                ueval env head
+
+        switch head.kind
+        case URef.Kind.Table
+            if ((table-getmeta head) == mt_closure)
+                let origenv = env
+                local env = (table-geti head 0)
+                let f = (table-geti head 1)
+                let params = (table-geti f 1)
+                let eachf =
+                    table-eachi
+                        inline (i value origenv env params)
+                            if (i > 0)
+                                let name =
+                                    table-geti params (i - 1)
+                                env =
+                                    table-set env name
+                                        ueval origenv (copy value)
+                            ;
+                eachf expr origenv env params
+                let expr = (table-geti f 2)
+                ueval (copy env) expr
+            else
+                print "cannot apply table:" (uref-repr expr)
+                return (URef)
+        case URef.Kind.Symbol
+            fn verify (val K)
+                if (val.kind != K)
+                    print K "expected, got" (uref-repr val)
+
+            inline binop (f)
+                let a = (ueval env (table-geti expr 1))
+                verify a URef.Kind.Number
+                let b = (ueval env (table-geti expr 2))
+                verify b URef.Kind.Number
+                return
+                    number-add a b
+
+            inline eval-let ()
+                let f =
+                    table-each
+                        inline (k v origenv env)
+                            env =
+                                table-set env (copy k)
+                                    ueval origenv (copy v)
+                            ;
+                local newenv = env
+                f expr env newenv
+                return (ueval newenv (table-geti expr 1))
+
+            inline eval-fn ()
+                return
+                    table-setmeta
+                        table env expr
+                        mt_closure
+
+            using builtins
+            switch (head as integer)
+            case + (binop number-add)
+            case - (binop number-sub)
+            case * (binop number-mul)
+            case / (binop number-div)
+            case let (eval-let)
+            case fn (eval-fn)
+            default
+                print "syntax error:" (uref-repr expr)
+                return (URef)
+        default
+            print "cannot apply:" (uref-repr expr)
+            return (URef)
+    default
+        return expr
+
+###############################################################################
+
+fn translate-quote-recur (value)
+    returning URef
+    let recur = this-function
+    let T = ('typeof value)
+    match T
+    case list
+        let l = (value as list)
+        return
+            fold (t = (table)) for i elem in (enumerate l)
+                label done
+                    if (('typeof elem) == list)
+                        elem as:= list
+                        if ((countof elem) == 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)
+                                    value := (recur value)
+                                    merge done
+                                        try
+                                            table-set t key value
+                                        except (err)
+                                            error (repr err)
+                                default;
+                    key := (recur elem)
+                    try
+                        table-append t key
+                    except (err)
+                        error (repr err)
+    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))
+
+inline translate-quote (value)
+    translate-quote-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

          
@@ 762,6 994,9 @@ fn uref-tests ()
         table-set t (number 10) (ustring "test")
     print
         uref-repr t
+    print
+        uref-repr
+            uquote (test "test" 1 2 3 (a b c) [d e] 3.5 (: (1 2 3) (4 5 6)))
 
 fn uarray-tests ()
     let a = (table)

          
@@ 782,9 1017,30 @@ fn uarray-tests ()
     #uarray-dump a
 
 try
-    #table-tests;
+    print
+        uref-repr
+            ueval
+                global-environment;
+                uquote
+                    let
+                        : a 2
+                        : b 2.5
+                        : c 4
+                        : make-seq
+                            fn (f1 f2)
+                                fn (x y z)
+                                    f2 (f1 x y) z
+                        : pow2
+                            fn (x)
+                                * x x
+                        let
+                            : muladd (make-seq * +)
+                            muladd (pow2 c) b a
+
+
+   #table-tests;
     #number-tests;
-    uref-tests;
+    #uref-tests;
     #uarray-tests;
 #
     print "final emptied table:" t

          
M testing/test_uvm2.sc +23 -0
@@ 370,6 370,29 @@ run-stage;
 
 ###############################################################################
 
+type i64f64 <: (integer 128)
+
+let MANTISSA_MAX = (-1:u64 as f64)
+let i128 = (integer 128 true)
+let i256 = (integer 256 true)
+
+fn... from-double (d : f64)
+    let u = (d as i64)
+    let v = (((d % 1.0:f64) * MANTISSA_MAX) as i64)
+    ((u as i128) << 64) | (v as i128)
+
+fn... to-double (d : i128)
+    let u = ((d >> 64) as f64)
+    let v = (((d & -1:u64) as f64) / MANTISSA_MAX)
+    u + v
+
+let P = ((from-double pi:f64) as i256)
+print
+    pi:f64 * pi:f64
+    to-double (((P * P) >> 64) as i128)
+
+###############################################################################
+
 #fn table-tests ()
     let t = (table)
     print "empty table:" t

          
A => testing/test_uvm3.sc +247 -0
@@ 0,0 1,247 @@ 
+using import struct
+using import enum
+using import Map
+using import Array
+using import String
+
+import ..lib.tukan.use
+using import tukan.libbf
+using import tukan.thread
+
+# 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)
+        print "drop!"
+
+global number_context =
+    LocalStorage
+        fn () (NumberContext)
+
+#fn get_context ()
+
+do
+    print (qualifiersof (@ number_context))
+
+do
+    print (qualifiersof (@ number_context))
+
+#
+    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;
+