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;
+