# HG changeset patch # User Leonard Ritter # Date 1712076814 -7200 # Tue Apr 02 18:53:34 2024 +0200 # Node ID eb7574af617eacdde632dfd806a7ae16ef1dc33b # Parent 299d9ed0be034b9c0d1ce07027526d5bf7267667 * core, Array: initial support for `new&` and `newcopy&` placement constructors * caret: initial work on `new` operator diff --git a/lib/scopes/Array.sc b/lib/scopes/Array.sc --- a/lib/scopes/Array.sc +++ b/lib/scopes/Array.sc @@ -508,6 +508,35 @@ _items = items _count = count + fn __new (self opts...) + cls := typeof self + let items... = (filter-items opts...) + let count = (va-countof items...) + static-assert (count <= cls.Capacity) "capacity exceeded" + let items = ('malloc-array cls.Allocator cls.ElementType cls.Capacity) + assign-items cls count items items... + super-type.__new self + _items = items + _count = count + + """"Implements support for the `newcopy` operation. + fn __newcopy (self other) + viewing self other + returning void + T := typeof self + capacity := 'capacity other + new& self + _items = 'malloc-array T.Allocator T.ElementType capacity + old-items := deref other._items + new-items := self._items # get a view + destcount := self._count + for idx in (range (copy other._count)) + newcopy& (new-items @ idx) (old-items @ idx) + # grow count with successfully copied items so newarr's drop + handler properly frees only the items that have been + transferred so far. + destcount += 1 + """"Implements support for the `repr` operation. fn __repr (self) .. @@ -582,6 +611,22 @@ else none + """"Implements support for the `newcopy` operation. + fn __newcopy (self other) + viewing self other + returning void + T := typeof self + capacity := 'capacity other + items := 'malloc-array T.Allocator T.ElementType capacity + report (storagecast (view items)) + new& self + _items = items + _capacity = other._capacity + # TODO: items doesn't get moved into self, but why? + report (storagecast self._items) + lose items + ; + fn nearest-capacity (capacity count) assert (capacity != 0:usize) loop (new-capacity = capacity) @@ -609,6 +654,20 @@ _count = count _capacity = capacity + fn __new (self opts...) + cls := typeof self + let capacity = + nearest-capacity DEFAULT_CAPACITY + (va-option capacity opts... DEFAULT_CAPACITY) as usize + let items... = (filter-items opts...) + let count = (va-countof items...) + let capacity = (nearest-capacity capacity count) + let items = ('malloc-array cls.Allocator cls.ElementType capacity) + assign-items cls count items items... + super-type.__new self + _items = items + _count = count + _capacity = capacity """"Implements support for the `repr` operation. fn __repr (self) diff --git a/lib/scopes/compiler/pilot/caret.sc b/lib/scopes/compiler/pilot/caret.sc --- a/lib/scopes/compiler/pilot/caret.sc +++ b/lib/scopes/compiler/pilot/caret.sc @@ -313,7 +313,7 @@ static-if nullable? static-assert (nullindex == 0) type (do name) < supertype :: caret-storage-type - Type := Unknown + Type := void PointerType := voidstar MutablePointerType := mutable PointerType Nullable? := nullable? @@ -326,7 +326,7 @@ inline extract-types (T) T := imply T type static-if (T < caret) - static-if (T.Type == Unknown) T.Types... + static-if (T.Type == void) T.Types... else T.Type else T @@ -354,24 +354,21 @@ ---------+-------+---------+---------+--------- unique&^ | weak | shared | shared | unique& -type weakcaret < caret -weak^ := weakcaret +type weak^ < caret + +type shared^ < caret -type sharedcaret < caret +type unique&^ < caret -type uniquecaret < caret -unique^ := uniquecaret +type unique^ < caret -type uniqueviewcaret < caret -unique&^ := uniqueviewcaret +recursive-type-factory weak^ "weak^" -recursive-type-factory weakcaret "weak^" +recursive-type-factory shared^ "^" -recursive-type-factory sharedcaret "^" +recursive-type-factory unique&^ "unique&^" -recursive-type-factory uniquecaret "unique^" - -recursive-type-factory uniqueviewcaret "unique&^" +recursive-type-factory unique^ "unique^" @@ memo inline drop-function-pointer (T) @@ -387,25 +384,71 @@ else func (imply func (@ (function void (viewof &T)))) as DropFunctionType +""""produces a voidstar pointer to the (uninitialized) data, along with the + tag that needs to be OR-ed into the pointer. +fn caret-malloc (size) + assert (size <= max-allocation-size) "allocation too big" + AllocSize := size + caret-header-size + AllocLogAlign := logsize AllocSize + AllocAlign := 1:usize << AllocLogAlign + AllocAlignMask := AllocAlign - 1 + LogSizeTag := logsizetag AllocLogAlign + ptr := aligned_alloc AllocAlign AllocSize + ptr as:= caret-header-pointer-rw + ptr.strong = locked-unique-bit + ptr.weak = 0 + ptr.ondrop = null + header := ptr + ptr := ptrtoint ptr intptr + assert ((ptr & AllocAlignMask) == 0) + ptr := ptr + caret-header-size + inttoptr ptr voidstar, LogSizeTag, header + +""""reserves heap memory for a new value of type `T` and returns it as a + `unique^ T`. T must support the `__new` protocol. + + fn __new (self ...) + ... + + `__new` may panic, but not raise any runtime errors. +@@ memo +inline gen-new (initf T) + inline (...) + size := sizeof T + ptr tag header := caret-malloc size + memset (ptr as (mutable rawstring)) 0 size + new_handler := typeattr T '__new (inline () none) + ptr := ptr as (mutable @T) + initf (@ (view ptr)) ... + static-if (not plain? T) + header.ondrop = drop-function-pointer T + ptr := ptrtoint ptr uniqueintptr + ptr := bor ptr (bitcast tag uniqueintptr) + bitcast ptr (unique^ T) + +inline new (T ...) + (gen-new new& T) ... + +inline newcopy (self) + T := typeof self + (gen-new newcopy& T) self + type+ caret - inline __typecall (cls ...) + inline... __typecall + case (cls, T : type, ...) static-if (cls == this-type) - static-error "use ^, mutable^ or mutable&^ to construct a caret type" + static-error "use ^, unique^ or unique&^ to construct a caret type" else - T R... := ... - static-if ((typeof T) == type) - cls.gen-type T R... - else - 'wrap cls (cls.Type ...) + T := cls.gen-type T + static-fold (T) for R in (va-each ...) + cls.gen-type2 T R @@ memo inline __typemerge (cls T) cls := unqualified cls T := unqualified T - static-if (T < caret) + static-if ((T < caret) or (T == Nothing)) cls ^ T - elseif (T == Nothing) - cls ^ ^T inline rc-stats (self) h := getheader self @@ -421,42 +464,6 @@ weak = w unique? = u? - @@ memo - inline alloc-metrics (cls) - Size := sizeof cls.Type - static-assert (Size <= max-allocation-size) "type too big" - AllocSize := Size + caret-header-size - AllocLogAlign := const logsize AllocSize - AllocAlign := 1:usize << AllocLogAlign - AllocAlignMask := AllocAlign - 1 - LogSizeTag := logsizetag AllocLogAlign - pass Size AllocAlign AllocSize AllocAlignMask LogSizeTag - - @@ memo - inline wrapper (cls) - fn (value) - value := move value - Size AllocAlign AllocSize AllocAlignMask LogSizeTag := alloc-metrics cls - #dump Size AllocAlign AllocSize AllocAlignMask LogSizeTag - ptr := aligned_alloc AllocAlign AllocSize - caretlog "alloc" cls ptr - ptr as:= caret-header-pointer-rw - ptr.strong = static-if (cls < sharedcaret) 1 - else locked-unique-bit - ptr.weak = 0 - ptr.ondrop = drop-function-pointer cls.Type # todo - ptr := ptrtoint ptr intptr - assert ((ptr & AllocAlignMask) == 0) - ptr := ptr + caret-header-size - ptr := inttoptr ptr cls.MutablePointerType - store value ptr - ptr := ptrtoint ptr uniqueintptr - ptr := ptr | (bitcast LogSizeTag uniqueintptr) - bitcast ptr cls - - inline wrap (cls value) - (wrapper cls) value - inline __toref (self) cls := typeof self self := view self @@ -464,22 +471,48 @@ bitcast self uniqueintptr bitcast pointer-mask uniqueintptr ptr := inttoptr self - (cls < sharedcaret) cls.PointerType cls.MutablePointerType + (cls < shared^) cls.PointerType cls.MutablePointerType @ ptr -type+ uniqueviewcaret - inline wrap (cls value) - static-assert "can't wrap in unique&^" + """"it is not recommended to use this function directly, as enumerants + can fluctuate unpredictably under type changes; instead, use `downcast` + or `downcast...` to specialize the type. + inline __tagof (self) + inplace_tag := (bitcast (view self) intptr) & variant-tag-mask-inplace + (inplace_tag >> variant-tag-shift) as VariantTagType + + @@ memo + inline __typetagof (cls T) + cls := unqualified cls + static-if ((T < caret) and (caret-subset? T cls)) + caret-type-tag T.Type cls.Types... + else + caret-type-tag T cls.Types... - fn __copy (self) - static-assert "can't copy unique^" # todo: yet +@@ memo +inline variantcaster (A B) + fn (self) + inplace_tag := (bitcast (view self) intptr) & variant-tag-mask-inplace + tag := (inplace_tag >> variant-tag-shift) as VariantTagType + newtag := caret-tag tag A B + inline () + assert false "corrupted tag detected" + new_inplace_tag := (newtag as intptr) << variant-tag-shift + delta_tag := inplace_tag ^ new_inplace_tag + bitcast + bxor (bitcast self uniqueintptr) + bitcast delta_tag uniqueintptr + B +type+ unique&^ inline __getattr (self key) cls := typeof self value := getelementptr (inttoptr self cls.MutablePointerType) 0 key T := elementof (typeof value) ptrtoint value (this-type T) + inline unique& (self) self + fn __drop (self) viewing self returning void @@ -493,6 +526,12 @@ "reference corruption detected (while dropping borrowed unique)" ; + inline __printer (self print) + print + /p + Styled.Type "unique&^" + @ self + inline weakcaretdrop (name h) ptr := &h as voidstar # release the weak reference for good @@ -525,16 +564,64 @@ assert (ptr == pptr) "realloc(): truncation moved pointer" weakcaretdrop name h -type+ uniquecaret - fn __copy (self) - static-assert "can't copy unique^" # todo: yet - +type+ unique^ inline __getattr (self key) cls := typeof self value := getelementptr (inttoptr self cls.MutablePointerType) 0 key T := elementof (typeof value) ptrtoint value (this-type T) + @@ memo + inline __downcast (cls T) + static-if ((T < unique^) and (caret-subset? T cls)) + variantcaster (unqualified cls) T + else + # we won't move self here because that would require a copy and + a drop + castf := this-function cls (this-type T) + inline (self) + @ (castf (view self)) + + @@ memo + inline __imply (cls T) + cls := unqualified cls + T := unqualified T + static-if ((T < unique^) and (caret-subset? cls T)) + variantcaster cls T + + @@ memo + inline __rimply (T cls) + cls := unqualified cls + T := unqualified T + static-if ((T == Nothing) and (caret-subset? (unique^ T) cls)) + fn (self) + bitcast (nullof intptr) cls + + inline share& (self) + """"split unique in two parts: a (locked) shared^ and a unique&^, which + must be dropped first before the shared caret can be used. + cls := typeof self + pass + bitcast (default-copy self) (shared^ cls.Types...) + bitcast (move self) (unique&^ cls.Types...) + + fn share (self) + cls := typeof self + static-if cls.Nullable? + if ((storagecast (view self)) == 0) + return + bitcast (default-copy self) (shared^ cls.Types...) + h := getheader (view self) + __ ok? := cmpxchg &h.strong locked-unique-bit 1 + assert ok? + "reference corruption detected (while sharing unique^)" + bitcast (move self) (shared^ cls.Types...) + + @@ memo + inline __as (cls T) + static-if ((unique? cls) and + ((T == shared^) or (T == (shared^ cls.Types...)))) share + fn __drop (self) viewing self returning void @@ -549,18 +636,16 @@ atomicrmw add &h.weak 1 __ ok? := cmpxchg &h.strong locked-unique-bit 0 assert ok? - "reference corruption detected (while dropping borrowed unique)" + "reference corruption detected (while dropping unique^)" caretdrop "unique" self h 1 -type+ weakcaret - inline __typecall (cls ...) - T R... := ... - static-if ((typeof T) == type) - cls.gen-type T R... - else - value := ... - imply value cls + inline __printer (self print) + print + /p + Styled.Type "unique^" + @ self +type+ weak^ fn __drop (self) viewing self returning void @@ -572,13 +657,10 @@ weakcaretdrop "weak" (getheader self) ; - inline __copy (self) - 'wrap-caret (typeof self) self - inline wrap (cls value) static-error "how did you get here?" - inline wrap-caret (cls self) + inline _wrap-caret (cls self) self := view self cls := typeof self static-if cls.Nullable? @@ -589,6 +671,16 @@ # we are allowed to dupe here because we increased weak bitcast (default-copy self) cls + inline __copy (self) + _wrap-caret (typeof self) self + + inline... __new + case (self) + # nothing to do, already zero + case (self, value) + T := typeof self + assign (imply value T) self + # try to get a strong reference fn upgrade (self) cls := typeof self @@ -604,7 +696,7 @@ saving us this entire silly loop, but i don't think it exists. s ok? := cmpxchg (& h.strong) s (s + 1) if ok? # it's aliiive! - dest := sharedcaret cls.Type + dest := shared^ cls.Type static-if (view? self) return (bitcast (default-copy self) dest) else @@ -618,46 +710,19 @@ inline () (dupe (nullof cls)) elseif or - T < sharedcaret - T < uniquecaret - T < uniqueviewcaret + T < shared^ + T < unique^ + T < unique&^ inline (self) - wrap-caret (this-type T.Type) self - -inline _downcast + _wrap-caret (this-type T.Type) self -type+ sharedcaret - """"it is not recommended to use this function directly, as enumerants - can fluctuate unpredictably under type changes; instead, use `downcast` - or `downcast...` to specialize the type. - inline __tagof (self) - inplace_tag := (bitcast (view self) intptr) & variant-tag-mask-inplace - (inplace_tag >> variant-tag-shift) as VariantTagType - - @@ memo - inline __typetagof (cls T) - cls := unqualified cls - static-if ((T < sharedcaret) and (caret-subset? T cls)) - caret-type-tag T.Type cls.Types... - else - caret-type-tag T cls.Types... +type+ shared^ + inline share (self) self @@ memo inline __downcast (cls T) - static-if ((T < sharedcaret) and (caret-subset? T cls)) - fn (self) - cls := unqualified cls - inplace_tag := (bitcast (view self) intptr) & variant-tag-mask-inplace - tag := (inplace_tag >> variant-tag-shift) as VariantTagType - newtag := caret-tag tag cls T - inline () - assert false "corrupted tag detected" - new_inplace_tag := (newtag as intptr) << variant-tag-shift - delta_tag := inplace_tag ^ new_inplace_tag - bitcast - bxor (bitcast self uniqueintptr) - bitcast delta_tag uniqueintptr - T + static-if ((T < shared^) and (caret-subset? T cls)) + variantcaster (unqualified cls) T else # we won't move self here because that would require a copy and a drop @@ -669,19 +734,8 @@ inline __imply (cls T) cls := unqualified cls T := unqualified T - static-if ((T < sharedcaret) and (caret-subset? cls T)) - fn (self) - inplace_tag := (bitcast (view self) intptr) & variant-tag-mask-inplace - tag := (inplace_tag >> variant-tag-shift) as VariantTagType - newtag := caret-tag tag cls T - inline () - assert false "corrupted tag detected" - new_inplace_tag := (newtag as intptr) << variant-tag-shift - delta_tag := inplace_tag ^ new_inplace_tag - bitcast - bxor (bitcast self uniqueintptr) - bitcast delta_tag uniqueintptr - T + static-if ((T < shared^) and (caret-subset? cls T)) + variantcaster cls T fn __drop (self) viewing self @@ -731,51 +785,64 @@ @@ memo inline __rimply (T cls) - #static-if (T == cls.Type) - inline (self) - 'wrap cls self cls := unqualified cls T := unqualified T static-if ((T == Nothing) and (caret-subset? ^T cls)) fn (self) bitcast (nullof intptr) cls - - inline tounique (self) + fn unique (self) + """"move or copy self to produce a unique^ cls := typeof self - static-assert ((&? self) and (mutable&? self)) - .. (nameof (qualifiersof self)) - ": only a mutable& ^ may be acquired as unique" h := getheader (view self) assert (not 'locked-unique? h) "usage error: attempting to acquire unique^ twice" - h := if (h.strong != 1) + s := volatile-load &h.strong + if (s != 1) # need to copy contents first - self = 'wrap cls (copy (@ (view self))) - getheader (view self) - else h - s ok? := cmpxchg &h.strong 1 locked-unique-bit - assert ok? - "reference corruption detected (while acquiring unique)" - static-if (view? self) + newself := newcopy (@ (view self)) + drop self + newself + else + s ok? := cmpxchg &h.strong 1 locked-unique-bit + assert ok? + "reference corruption detected (while acquiring unique)" + # duping here is okay because the refcount is frozen + bitcast + move self + unique^ cls.Type + + fn unique& (self) + """"borrow or copy self to produce a unique&^ + viewing self + cls := typeof self + static-assert ((&? self) and (mutable&? self)) + .. (nameof (qualifiersof self)) + ": only a mutable& shared^ may be mutated" + h := getheader (view self) + assert (not 'locked-unique? h) + "usage error: attempting to acquire unique^ twice" + s := volatile-load &h.strong + if (s != 1) + # need to copy contents first + shared mutated := 'share& (newcopy (@ (view self))) + self = shared + mutated + else + s ok? := cmpxchg &h.strong 1 locked-unique-bit + assert ok? + "reference corruption detected (while acquiring unique)" # duping here is okay because the refcount is tagged as borrowed bitcast default-copy self - uniqueviewcaret cls.Type - else - # duping here is okay because the refcount is frozen - bitcast - move self - uniquecaret cls.Type + unique&^ cls.Types... @@ memo inline __as (cls T) - static-if (T == uniquecaret) - inline (self) - tounique (move self) - elseif (T == uniqueviewcaret) - inline (self) - tounique (view self) + static-if ((unique? cls) + and ((T == unique^) or (T == (unique^ cls.Types...)))) unique + elseif (((&? cls) and (mutable&? cls)) + and ((T == unique&^) or (T == (unique&^ cls.Types...)))) unique& inline __getattr (self key) self := view self @@ -787,27 +854,149 @@ inline __printer (self print) print /p - Styled.Type "^" + Styled.Type "shared^" @ self - nonef := inline () none type+ type inline __caret (T) - sharedcaret T + shared^ T @@ memo inline __^ (cls T) if (cls == T) - # pick correct caret type - C := static-if ((cls < weak^) or (T < weak^)) weak^ - elseif ((cls < unique^) and (T < unique^)) unique^ - elseif ((cls < unique&^) and (T < unique&^)) unique&^ - else sharedcaret - C.gen-type2 + inline (cls T) + # pick correct caret type + C := static-if (not (T < caret)) + static-if (cls < caret) cls + else shared^ + elseif ((cls < weak^) or (T < weak^)) weak^ + elseif ((cls < unique^) and (T < unique^)) unique^ + elseif ((cls < unique&^) and (T < unique&^)) unique&^ + else shared^ + C.gen-type2 cls T + +################################################################################ + +type+ typename + inline... __new + case (self) # zero-init + T := typeof self + static-if (not plain? T) + static-error + .. "`new&` of unique type " (static-repr T) + " only accepts copy/move construction" + case (self, value) # copy + newcopy& self value + + inline __newcopy (self other) + T := typeof self + assign (copy other) self + +################################################################################ + +spice struct-new-constructor (self args...) + cls := 'typeof self + trace-calling cls + let cls-value = cls + let cls = (cls as type) + let struct-fields = + try ('@ cls '__fields__) + except (err) `none + let argc = ('argcount args...) + let numfields = ('element-count cls) + let fields = (malloc-array Value numfields) + for i in (range numfields) + store (null as Value) (getelementptr fields i) + # collect initializers from arguments + for i in (range argc) + let arg = ('getarg args... i) + let key v = ('dekey arg) + let k = + if (key == unnamed) i + else + sc_type_field_index cls key + if (k >= numfields) + trace-error + .. "while initializing tuple fields of type " + repr cls + "excess argument passed to tuple constructor" + if ((load (getelementptr fields k)) != null) + trace-error + .. "while initializing struct fields of type " + repr cls + "field is already initialized" + let ET = (sc_type_element_at cls k) + let ET = (sc_strip_qualifiers ET) + let v = + do + sc_prove `(imply v ET) + store `(assign v (getelementref self k)) + getelementptr fields k + let block = (sc_expression_new) + # complete default initializers + for i in (range numfields) + elem := load (getelementptr fields i) + :: success + if (elem != null) + merge success elem + :: skip + if (('typeof struct-fields) == Nothing) + merge skip + let field = ('getarg struct-fields i) + let field = (field as type) + let elem constructor? = + try (_ ('@ field 'Default) false) + else + try (_ ('@ field 'Constructor) true) + else + merge skip + let elem = + if constructor? `(elem) + else elem + merge success `(assign elem (getelementref self i)) + skip :: + # default initializer + do + if (('typeof struct-fields) == Nothing) + trace-checking-argument cls-value + else + trace-checking-argument ('getarg struct-fields i) + sc_prove `(new& (getelementref self i)) + success (elem) :: + sc_expression_append block elem + free fields + sc_expression_append block `() + block + +type+ Struct + __new := struct-new-constructor + + fn __newcopy (self other) + cls := typeof self + viewing self + returning void + static-fold () for a b in + zip + va-each + va-dekey + __unpack-keyed-aggregate self + va-each + va-dekey + __unpack-keyed-aggregate other + newcopy& a b + +################################################################################ + +#inline malloc^ (T) + caret-malloc (sizeof T) + +#inline malloc-array^ (T count) + caret-malloc ((sizeof T) * count) do - let caret sharedcaret unique^ unique&^ weak^ + let caret shared^ unique^ unique&^ weak^ + let new locals; diff --git a/lib/scopes/core.sc b/lib/scopes/core.sc --- a/lib/scopes/core.sc +++ b/lib/scopes/core.sc @@ -9373,6 +9373,7 @@ sc_expression_append block result loop (i result = 0 result) if (i == numfields) + free fields break block let elem = (load (getelementptr fields i)) let elem = @@ -9570,6 +9571,7 @@ loop (i result = 0 `(dupe (nullof cls))) sc_expression_append block result if (i == numfields) + free fields break block let elem = if ((load (getelementptr fields i)) == null) @@ -10812,6 +10814,19 @@ and (plain? T) ((storageof T) < immutable) #------------------------------------------------------------------------------- + +# inplace copy/move-constructor +inline newcopy& (self other) + T := typeof self + '__newcopy (view self) (imply (view other) T) + ; + +# inplace constructor +inline new& (self ...) + '__new (view self) ... + ; + +#------------------------------------------------------------------------------- # constants #------------------------------------------------------------------------------- diff --git a/src/globals.cpp b/src/globals.cpp --- a/src/globals.cpp +++ b/src/globals.cpp @@ -3623,7 +3623,6 @@ DEFINE_EXTERN_C_FUNCTION(sc_refer_storage_class, TYPE_Symbol, TYPE_Type); DEFINE_EXTERN_C_FUNCTION(sc_strip_qualifiers, TYPE_Type, TYPE_Type); - DEFINE_EXTERN_C_FUNCTION(sc_strip_lifetime_qualifiers, TYPE_Type, TYPE_Type); DEFINE_EXTERN_C_FUNCTION(sc_canonical_type, TYPE_Type, TYPE_Type); DEFINE_EXTERN_C_FUNCTION(sc_image_type, TYPE_Type, diff --git a/src/prover.cpp b/src/prover.cpp --- a/src/prover.cpp +++ b/src/prover.cpp @@ -3216,7 +3216,7 @@ const Type *Tptr = nullptr; if (is_ref) { READ_NODEREF_TYPEOF(argT); - T = Tptr = SCOPES_GET_RESULT(ref_to_ptr(argT)); + T = Tptr = SCOPES_GET_RESULT(storage_type(SCOPES_GET_RESULT(ref_to_ptr(argT)))); dep = _argT; } else { READ_STORAGETYPEOF(argT); diff --git a/testing/test_caret.sc b/testing/test_caret.sc --- a/testing/test_caret.sc +++ b/testing/test_caret.sc @@ -8,7 +8,7 @@ T := ^i32 test (T.Type == i32) test ((superof T) == (^ (superof i32))) - test ((superof ^immutable) == sharedcaret) + test ((superof ^immutable) == shared^) do global dropcount = 0 @@ -29,12 +29,18 @@ report "copy" super-type.__copy self + fn __newcopy (self other) + copycount += 1 + report "__newcopy" + super-type.__newcopy self other + fn doit (self) cls := typeof self static-assert (cls == this-type) report "doit" self - local n : ^U 3 6 9 + n := new U 3 6 9 + local n = 'share n # increases the refcount of n and m to 2 - copies are clones; little cost. m := copy n test (not mutable&? ((@ m) . x)) @@ -65,6 +71,8 @@ test (copycount == 1) test (dropcount == 2) +run-stage; + # using strong references to build a tree this tests if a complex tree of strong references is cleaned up properly do @@ -80,10 +88,10 @@ inline... new case (name : string,) - RcType + new this-type _name = name case (parent : RcType, name : string, ) - self := RcType + self := new this-type _name = name deref ('append ((@ parent) . children) self) @@ -102,6 +110,7 @@ deref self._name let root = (DemoNode.new "root") + print root do let n1 = (DemoNode.new root "n1") let n2 = (DemoNode.new root "n2") @@ -154,15 +163,18 @@ inline... new case (name : string,) - local self := RcType - _name = name + local self := 'share + new this-type + _name = name case (pparent, name : string, ) pparent := view pparent - parent := @ (pparent as unique&^) - self := RcType - parent = pparent - _name = name - ('append parent.children self) as unique&^ + parent := @ ('unique& pparent) + self uself := 'share& + new this-type + parent = pparent + _name = name + 'append parent.children self + uself inline __== (self other) if ((typeof self) == (typeof other)) @@ -247,9 +259,10 @@ left : One right : One - n := ^Node - left = One 1 - right = One 2 + n := 'share + new Node + left = One 1 + right = One 2 test ((One.refcount) == 2) # making a copy (clone) only of a subattribute - but this clones the entire object. @@ -267,19 +280,22 @@ test ((u32 ^ (^ u64)) == (u64 ^ u32)) test (((^ u32) ^ (^ u64)) == (u64 ^ u32)) +test (((unique^ u32) ^ u64) == (unique^ u32 u64)) + run-stage; do fn f (x) - if (x == 0) - ^u32 1:u32 - else - if (x == 1) - ^u64 2:u64 - elseif (x == 2) - ^f32 3.0 + 'share + if (x == 0) + new u32 1:u32 else - none + if (x == 1) + new u64 2:u64 + elseif (x == 2) + new f32 3.0 + else + none A := f 0 B := f 1 @@ -336,6 +352,7 @@ ; + #do # singleton test T := ^One