Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file pool.ml
1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216open!ImportopenPool_intfmoduleTuple_type=Tuple_typeletfailwiths=Error.failwithsletphys_equal=Caml.(==)letarch_sixtyfour=Sys.word_size=64moduleInt=structletnum_bits=Int.num_bitsletmax_value=Caml.max_intletto_string=string_of_intendletsprintf=Printf.sprintfletconcatl=Base.String.concat~sep:""lmoduletypeS=SmodulePool=structletgrow_capacity~capacity~old_capacity=matchcapacitywith|None->ifold_capacity=0then1elseold_capacity*2|Somecapacity->ifcapacity<=old_capacitythenfailwiths"Pool.grow got too small capacity"(`capacitycapacity,`old_capacityold_capacity)[%sexp_of:[`capacityofint]*[`old_capacityofint]];capacity;;moduleSlots=Tuple_type.Slotsletmax_slot=14(* The pool is represented as a single [Uniform_array.t], where index zero has the
metadata about the pool and the remaining indices are the tuples layed out one after
the other. Each tuple takes [1 + slots_per_tuple] indices in the pool, where the
first index holds a header and the remaining indices hold the tuple's slots:
{v
| header | s0 | s1 | ... | s<N-1> |
v}
A [Pointer.t] to a tuple contains the integer index where its header is, as well as
(a mask of) the tuple's unique id.
The free tuples are singly linked via the headers.
When a tuple is in use, its header is marked to indicate so, and also to include the
tuple's unique id. This allows us to check in constant time whether a pointer is
valid, by comparing the id in the pointer with the id in the header.
When a tuple is not in use, its header is part of the free list, and its tuple slots
have dummy values of the appropriate types, from the [dummy] tuple supplied to
[create]. We must have dummy values of the correct type to prevent a segfault in
code that (mistakenly) uses a pointer to a free tuple.
For [Pool.Unsafe], a slot in a free object is guaranteed to be an int; it must not be
pointer to prevent a space leak. However, the int in the slot may not represent a
valid value of the type.
*)moduleSlot=structtype('slots,'a)t=int[@@derivingsexp_of]letequal(t1:(_,_)t)t2=t1=t2lett0=1lett1=2lett2=3lett3=4lett4=5lett5=6lett6=7lett7=8lett8=9lett9=10lett10=11lett11=12lett12=13lett13=14let%test_=t13=max_slotend(* We only have [Int.num_bits] bits available for pool pointers. The bits of a pool
pointer encode two things:
- the tuple's array index in the pool
- the tuple's identifier (not necessarily unique)
We choose [array_index_num_bits] as large as needed for the maximum pool capacity
that we want to support, and use the remaining [masked_tuple_id_num_bits] bits for
the identifier. 64-bit and 32-bit architectures typically have very different
address-space sizes, so we choose [array_index_num_bits] differently. *)letarray_index_num_bits=ifarch_sixtyfourthen(assert(Int.num_bits=63);30)else(assert(Int.num_bits=31||Int.num_bits=32);22);;letmasked_tuple_id_num_bits=Int.num_bits-array_index_num_bitslet%test_=array_index_num_bits>0let%test_=masked_tuple_id_num_bits>0let%test_=array_index_num_bits+masked_tuple_id_num_bits<=Int.num_bitsletmax_array_length=1lslarray_index_num_bitsmoduleTuple_id:sigtypet=privateint[@@derivingsexp_of]includeInvariant.Swithtypet:=tvalto_string:t->stringvalequal:t->t->boolvalinit:tvalnext:t->tvalof_int:int->tvalto_int:t->intvalexamples:tlistend=structtypet=int[@@derivingsexp_of](* We guarantee that tuple ids are nonnegative so that they can be encoded in
headers. *)letinvariantt=assert(t>=0)letto_string=Int.to_stringletequal(t1:t)t2=t1=t2letinit=0letnextt=ifarch_sixtyfourthent+1elseift=Int.max_valuethen0elset+1letto_intt=tletof_inti=ifi<0thenfailwiths"Tuple_id.of_int got negative int"i[%sexp_of:int];i;;letexamples=[0;1;0x1FFF_FFFF;Int.max_value]endlettuple_id_mask=(1lslmasked_tuple_id_num_bits)-1modulePointer:sig(* [Pointer.t] is an encoding as an [int] of the following sum type:
{[
| Null
| Normal of { header_index : int; masked_tuple_id : int }
]}
The encoding is chosen to optimize the most common operation, namely tuple-slot
access, the [slot_index] function. The encoding is designed so that [slot_index]
produces a negative number for [Null], which will cause the subsequent array bounds
check to fail. *)type'slotst=privateint[@@derivingsexp_of,typerep]includeInvariant.S1withtype'at:='atvalphys_compare:'at->'at->intvalphys_equal:'at->'at->bool(* The null pointer. [null] is a function due to issues with the value restriction. *)valnull:unit->_tvalis_null:_t->bool(* Normal pointers. *)valcreate:header_index:int->Tuple_id.t->_tvalheader_index:_t->intvalmasked_tuple_id:_t->intvalslot_index:_t->(_,_)Slot.t->intvalfirst_slot_index:_t->intmoduleId:sigtypet[@@derivingbin_io,sexp]valto_int63:t->Int63.tvalof_int63:Int63.t->tendvalto_id:_t->Id.tvalof_id_exn:Id.t->_tend=struct(* A pointer is either [null] or the (positive) index in the pool of the next-free
field preceeding the tuple's slots. *)type'slotst=int[@@derivingtyperep]letsexp_of_t_t=Sexp.Atom(sprintf"<Pool.Pointer.t: 0x%08x>"t)letphys_equal(t1:_t)t2=phys_equalt1t2letphys_compare=compareletnull()=-max_slot-1letis_nullt=phys_equalt(null())(* [null] must be such that [null + slot] is an invalid array index for all slots.
Otherwise get/set on the null pointer may lead to a segfault. *)let%test_=null()+max_slot<0letcreate~header_index(tuple_id:Tuple_id.t)=header_indexlor((Tuple_id.to_inttuple_idlandtuple_id_mask)lslarray_index_num_bits);;letheader_index_mask=(1lslarray_index_num_bits)-1letmasked_tuple_idt=tlsrarray_index_num_bitsletheader_indext=tlandheader_index_maskletinvariant_t=ifnot(is_nullt)thenassert(header_indext>0)let%test_unit_=invariantignore(null())let%test_unit_=List.iterTuple_id.examples~f:(funtuple_id->invariantignore(create~header_index:1tuple_id));;letslot_indextslot=header_indext+slotletfirst_slot_indext=slot_indextSlot.t0moduleId=structincludeInt63letto_int63t=tletof_int63i=iendletto_idt=Id.of_inttletof_id_exnid=trylett=Id.to_int_exnidinifis_nulltthentelse(letshould_equal=create~header_index:(header_indext)(Tuple_id.of_int(masked_tuple_idt))inifphys_equaltshould_equalthentelsefailwiths"should equal"should_equal[%sexp_of:_t])with|exn->failwiths"Pointer.of_id_exn got strange id"(id,exn)[%sexp_of:Id.t*exn];;endmoduleHeader:sig(* A [Header.t] is an encoding as an [int] of the following type:
{[
| Null
| Free of { next_free_header_index : int }
| Used of { tuple_id : int }
]}
If a tuple is free, its header is set to either [Null] or [Free] with
[next_free_header_index] indicating the header of the next tuple on the free list.
If a tuple is in use, it header is set to [Used]. *)typet=privateint[@@derivingsexp_of]valnull:tvalis_null:t->boolvalfree:next_free_header_index:int->tvalis_free:t->boolvalnext_free_header_index:t->int(* only valid if [is_free t] *)valused:Tuple_id.t->tvalis_used:t->boolvaltuple_id:t->Tuple_id.t(* only valid if [is_used t] *)end=structtypet=intletnull=0letis_nullt=t=0(* We know that header indices are [> 0], because index [0] holds the metadata. *)letfree~next_free_header_index=next_free_header_indexletis_freet=t>0letnext_free_header_indext=tletused(tuple_id:Tuple_id.t)=-1-(tuple_id:>int)letis_usedt=t<0lettuple_idt=Tuple_id.of_int(-(t+1))let%test_unit_=List.iterTuple_id.examples~f:(funid->lett=usedidinassert(is_usedt);assert(Tuple_id.equal(tuple_idt)id));;letsexp_of_tt=ifis_nulltthenSexp.Atom"null"elseifis_freetthenSexp.(List[Atom"Free";Atom(Int.to_string(next_free_header_indext))])elseSexp.(List[Atom"Used";Atom(Tuple_id.to_string(tuple_idt))]);;endletmetadata_index=0letstart_of_tuples_index=1letmax_capacity~slots_per_tuple=(max_array_length-start_of_tuples_index)/(1+slots_per_tuple);;let%test_unit_=forslots_per_tuple=1tomax_slotdoassert(start_of_tuples_index+((1+slots_per_tuple)*max_capacity~slots_per_tuple)<=max_array_length)done;;moduleMetadata=structtype'slotst={(* [slots_per_tuple] is number of slots in a tuple as seen by the user; i.e. not
counting the next-free pointer. *)slots_per_tuple:int;capacity:int;mutablelength:int;mutablenext_id:Tuple_id.t;mutablefirst_free:Header.t(* [dummy] is [None] in an unsafe pool. In a safe pool, [dummy] is [Some a], with
[Uniform_array.length a = slots_per_tuple]. [dummy] is actually a tuple value
with the correct type (corresponding to ['slots]), but we make the type of
[dummy] be [Obj.t Uniform_array.t] because we can't write that type here. Also,
the purpose of [dummy] is to initialize a pool element, making [dummy] an [Obj.t
Uniform_array.t] lets us initialize a pool element using [Uniform_array.blit]
from [dummy] to the pool, which is an [Obj.t Uniform_array.t]. *);dummy:Obj.tUniform_array.tsexp_opaqueoption}[@@derivingfields,sexp_of]letarray_indices_per_tuplet=1+t.slots_per_tupleletarray_lengtht=start_of_tuples_index+(t.capacity*array_indices_per_tuplet)letheader_index_to_tuple_numt~header_index=(header_index-start_of_tuples_index)/array_indices_per_tuplet;;lettuple_num_to_header_indexttuple_num=start_of_tuples_index+(tuple_num*array_indices_per_tuplet);;lettuple_num_to_first_slot_indexttuple_num=tuple_num_to_header_indexttuple_num+1;;letis_fullt=t.length=t.capacityendopenMetadata(* We use type [Obj.t] because the array holds a mix of integers as well as OCaml values
of arbitrary type. *)type'slotst=Obj.tUniform_array.tletmetadata(typeslots)(t:slotst)=Uniform_array.unsafe_gettmetadata_index|>(Obj.obj:_->slotsMetadata.t);;letlengtht=(metadatat).lengthletsexp_of_tsexp_of_tyt=Metadata.sexp_of_tsexp_of_ty(metadatat)(* Because [unsafe_header] and [unsafe_set_header] do not do a bounds check, one must be
sure that one has a valid [header_index] before calling them. *)letunsafe_headert~header_index=Uniform_array.unsafe_gettheader_index|>(Obj.obj:_->Header.t);;letunsafe_set_headert~header_index(header:Header.t)=Uniform_array.unsafe_set_int_assuming_currently_inttheader_index(header:>int);;letheader_index_is_in_boundst~header_index=header_index>=start_of_tuples_index&&header_index<Uniform_array.lengtht;;letunsafe_pointer_is_livetpointer=letheader_index=Pointer.header_indexpointerinletheader=unsafe_headert~header_indexinHeader.is_usedheader&&Tuple_id.to_int(Header.tuple_idheader)landtuple_id_mask=Pointer.masked_tuple_idpointer;;letpointer_is_validtpointer=header_index_is_in_boundst~header_index:(Pointer.header_indexpointer)(* At this point, we know the pointer isn't [null] and is in bounds, so we know it is
the index of a header, since we maintain the invariant that all pointers other than
[null] are. *)&&unsafe_pointer_is_livetpointer;;letid_of_pointer_tpointer=Pointer.to_idpointerletis_valid_header_indext~header_index=letmetadata=metadatatinheader_index_is_in_boundst~header_index&&0=(header_index-start_of_tuples_index)modMetadata.array_indices_per_tuplemetadata;;letpointer_of_id_exntid=tryletpointer=Pointer.of_id_exnidinifnot(Pointer.is_nullpointer)then(letheader_index=Pointer.header_indexpointerinifnot(is_valid_header_indext~header_index)thenfailwiths"invalid header index"header_index[%sexp_of:int];ifnot(unsafe_pointer_is_livetpointer)thenfailwith"pointer not live");pointerwith|exn->failwiths"Pool.pointer_of_id_exn got invalid id"(id,t,exn)[%sexp_of:Pointer.Id.t*_t*exn];;letinvariant_invariant_at:unit=tryletmetadata=metadatatinletcheckffield=f(Field.getfieldmetadata)inMetadata.Fields.iter~slots_per_tuple:(check(funslots_per_tuple->assert(slots_per_tuple>0)))~capacity:(check(funcapacity->assert(capacity>=0);assert(Uniform_array.lengtht=Metadata.array_lengthmetadata)))~length:(check(funlength->assert(length>=0);assert(length<=metadata.capacity)))~next_id:(checkTuple_id.invariant)~first_free:(check(funfirst_free->letfree=Array.create~len:metadata.capacityfalseinletr=reffirst_freeinwhilenot(Header.is_null!r)doletheader=!rinassert(Header.is_freeheader);letheader_index=Header.next_free_header_indexheaderinassert(is_valid_header_indext~header_index);lettuple_num=header_index_to_tuple_nummetadata~header_indexiniffree.(tuple_num)thenfailwiths"cycle in free list"tuple_num[%sexp_of:int];free.(tuple_num)<-true;r:=unsafe_headert~header_indexdone))~dummy:(check(function|Somedummy->assert(Uniform_array.lengthdummy=metadata.slots_per_tuple)|None->fortuple_num=0tometadata.capacity-1doletheader_index=tuple_num_to_header_indexmetadatatuple_numinletheader=unsafe_headert~header_indexinifHeader.is_freeheaderthen(letfirst_slot=tuple_num_to_first_slot_indexmetadatatuple_numinforslot=0tometadata.slots_per_tuple-1doassert(Obj.is_int(Uniform_array.gett(first_slot+slot)))done)done))with|exn->failwiths"Pool.invariant failed"(exn,t)[%sexp_of:exn*_t];;letcapacityt=(metadatat).capacityletis_fullt=Metadata.is_full(metadatat)letunsafe_add_to_free_listtmetadata~header_index=unsafe_set_headert~header_indexmetadata.first_free;metadata.first_free<-Header.free~next_free_header_index:header_index;;letset_metadata(typeslots)(t:slotst)metadata=Uniform_array.settmetadata_index(Obj.repr(metadata:slotsMetadata.t));;letcreate_array(typeslots)(metadata:slotsMetadata.t):slotst=lett=Uniform_array.create_obj_array~len:(Metadata.array_lengthmetadata)inset_metadatatmetadata;t;;(* Initialize tuples numbered from [lo] (inclusive) up to [hi] (exclusive). For each
tuple, this puts dummy values in the tuple's slots and adds the tuple to the free
list. *)letunsafe_init_rangetmetadata~lo~hi=(matchmetadata.dummywith|None->()|Somedummy->fortuple_num=lotohi-1doUniform_array.blit~src:dummy~src_pos:0~dst:t~dst_pos:(tuple_num_to_first_slot_indexmetadatatuple_num)~len:metadata.slots_per_tupledone);fortuple_num=hi-1downtolodounsafe_add_to_free_listtmetadata~header_index:(tuple_num_to_header_indexmetadatatuple_num)done;;letcreate_with_dummyslots~capacity~dummy=ifcapacity<0thenfailwiths"Pool.create got invalid capacity"capacity[%sexp_of:int];letslots_per_tuple=Slots.slots_per_tupleslotsinletmax_capacity=max_capacity~slots_per_tupleinifcapacity>max_capacitythenfailwiths"Pool.create got too large capacity"(capacity,`maxmax_capacity)[%sexp_of:int*[`maxofint]];letmetadata={Metadata.slots_per_tuple;capacity;length=0;next_id=Tuple_id.init;first_free=Header.null;dummy}inlett=create_arraymetadatainunsafe_init_rangetmetadata~lo:0~hi:capacity;t;;letcreate(typetuple)(slots:(tuple,_)Slots.t)~capacity~dummy=letdummy=ifSlots.slots_per_tupleslots=1thenUniform_array.singleton(Obj.repr(dummy:tuple))else(Obj.magic(dummy:tuple):Obj.tUniform_array.t)increate_with_dummyslots~capacity~dummy:(Somedummy);;(* Purge a pool and make it unusable. *)letdestroyt=letmetadata=metadatatin(* We clear out all the pool's entries, which causes all pointers to be invalid. This
also prevents the destroyed pool from unnecessarily keeping heap blocks alive.
This is similar to [free]ing all the entries with the difference that we make the
free list empty as well. *)(matchmetadata.dummywith|None->fori=start_of_tuples_indextoUniform_array.lengtht-1doUniform_array.unsafe_setti(Obj.repr0)done|Somedummy->fortuple_num=0tometadata.capacity-1doletheader_index=tuple_num_to_header_indexmetadatatuple_numinunsafe_set_headert~header_indexHeader.null;Uniform_array.blit~src:dummy~src_pos:0~dst:t~dst_pos:(header_index+1)~len:metadata.slots_per_tupledone);letmetadata={Metadata.slots_per_tuple=metadata.slots_per_tuple;capacity=0;length=0;next_id=metadata.next_id;first_free=Header.null;dummy=metadata.dummy}inset_metadatatmetadata;;let[@inlinenever]grow?capacityt=let{Metadata.slots_per_tuple;capacity=old_capacity;length;next_id;first_free=_;dummy}=metadatatinletcapacity=min(max_capacity~slots_per_tuple)(grow_capacity~capacity~old_capacity)inifcapacity=old_capacitythenfailwiths"Pool.grow cannot grow pool; capacity already at maximum"capacity[%sexp_of:int];letmetadata={Metadata.slots_per_tuple;capacity;length;next_id;first_free=Header.null;dummy}inlett'=create_arraymetadatainUniform_array.blit~src:t~src_pos:start_of_tuples_index~dst:t'~dst_pos:start_of_tuples_index~len:(old_capacity*Metadata.array_indices_per_tuplemetadata);destroyt;unsafe_init_ranget'metadata~lo:old_capacity~hi:capacity;fortuple_num=old_capacity-1downto0doletheader_index=tuple_num_to_header_indexmetadatatuple_numinletheader=unsafe_headert'~header_indexinifnot(Header.is_usedheader)thenunsafe_add_to_free_listt'metadata~header_indexdone;t';;let[@inlinenever]raise_malloc_fullt=failwiths"Pool.malloc of full pool"t[%sexp_of:_t];;letmalloc(typeslots)(t:slotst):slotsPointer.t=letmetadata=metadatatinletfirst_free=metadata.first_freeinifHeader.is_nullfirst_freethenraise_malloc_fullt;letheader_index=Header.next_free_header_indexfirst_freeinmetadata.first_free<-unsafe_headert~header_index;metadata.length<-metadata.length+1;lettuple_id=metadata.next_idinunsafe_set_headert~header_index(Header.usedtuple_id);metadata.next_id<-Tuple_id.nexttuple_id;Pointer.create~header_indextuple_id;;letunsafe_free(typeslots)(t:slotst)(pointer:slotsPointer.t)=letmetadata=metadatatinmetadata.length<-metadata.length-1;unsafe_add_to_free_listtmetadata~header_index:(Pointer.header_indexpointer);matchmetadata.dummywith|None->letpos=Pointer.first_slot_indexpointerinfori=0tometadata.slots_per_tuple-1doUniform_array.unsafe_clear_if_pointert(pos+i)done|Somedummy->Uniform_array.unsafe_blit~src:dummy~src_pos:0~len:metadata.slots_per_tuple~dst:t~dst_pos:(Pointer.first_slot_indexpointer);;letfree(typeslots)(t:slotst)(pointer:slotsPointer.t)=(* Check [pointer_is_valid] to:
- avoid freeing a null pointer
- avoid freeing a free pointer (this would lead to a pool inconsistency)
- be able to use unsafe functions after. *)ifnot(pointer_is_validtpointer)thenfailwiths"Pool.free of invalid pointer"(pointer,t)[%sexp_of:_Pointer.t*_t];unsafe_freetpointer;;letnew1ta0=letpointer=malloctinletoffset=Pointer.header_indexpointerinUniform_array.unsafe_sett(offset+1)(Obj.repra0);pointer;;letnew2ta0a1=letpointer=malloctinletoffset=Pointer.header_indexpointerinUniform_array.unsafe_sett(offset+1)(Obj.repra0);Uniform_array.unsafe_sett(offset+2)(Obj.repra1);pointer;;letnew3ta0a1a2=letpointer=malloctinletoffset=Pointer.header_indexpointerinUniform_array.unsafe_sett(offset+1)(Obj.repra0);Uniform_array.unsafe_sett(offset+2)(Obj.repra1);Uniform_array.unsafe_sett(offset+3)(Obj.repra2);pointer;;letnew4ta0a1a2a3=letpointer=malloctinletoffset=Pointer.header_indexpointerinUniform_array.unsafe_sett(offset+1)(Obj.repra0);Uniform_array.unsafe_sett(offset+2)(Obj.repra1);Uniform_array.unsafe_sett(offset+3)(Obj.repra2);Uniform_array.unsafe_sett(offset+4)(Obj.repra3);pointer;;letnew5ta0a1a2a3a4=letpointer=malloctinletoffset=Pointer.header_indexpointerinUniform_array.unsafe_sett(offset+1)(Obj.repra0);Uniform_array.unsafe_sett(offset+2)(Obj.repra1);Uniform_array.unsafe_sett(offset+3)(Obj.repra2);Uniform_array.unsafe_sett(offset+4)(Obj.repra3);Uniform_array.unsafe_sett(offset+5)(Obj.repra4);pointer;;letnew6ta0a1a2a3a4a5=letpointer=malloctinletoffset=Pointer.header_indexpointerinUniform_array.unsafe_sett(offset+1)(Obj.repra0);Uniform_array.unsafe_sett(offset+2)(Obj.repra1);Uniform_array.unsafe_sett(offset+3)(Obj.repra2);Uniform_array.unsafe_sett(offset+4)(Obj.repra3);Uniform_array.unsafe_sett(offset+5)(Obj.repra4);Uniform_array.unsafe_sett(offset+6)(Obj.repra5);pointer;;letnew7ta0a1a2a3a4a5a6=letpointer=malloctinletoffset=Pointer.header_indexpointerinUniform_array.unsafe_sett(offset+1)(Obj.repra0);Uniform_array.unsafe_sett(offset+2)(Obj.repra1);Uniform_array.unsafe_sett(offset+3)(Obj.repra2);Uniform_array.unsafe_sett(offset+4)(Obj.repra3);Uniform_array.unsafe_sett(offset+5)(Obj.repra4);Uniform_array.unsafe_sett(offset+6)(Obj.repra5);Uniform_array.unsafe_sett(offset+7)(Obj.repra6);pointer;;letnew8ta0a1a2a3a4a5a6a7=letpointer=malloctinletoffset=Pointer.header_indexpointerinUniform_array.unsafe_sett(offset+1)(Obj.repra0);Uniform_array.unsafe_sett(offset+2)(Obj.repra1);Uniform_array.unsafe_sett(offset+3)(Obj.repra2);Uniform_array.unsafe_sett(offset+4)(Obj.repra3);Uniform_array.unsafe_sett(offset+5)(Obj.repra4);Uniform_array.unsafe_sett(offset+6)(Obj.repra5);Uniform_array.unsafe_sett(offset+7)(Obj.repra6);Uniform_array.unsafe_sett(offset+8)(Obj.repra7);pointer;;letnew9ta0a1a2a3a4a5a6a7a8=letpointer=malloctinletoffset=Pointer.header_indexpointerinUniform_array.unsafe_sett(offset+1)(Obj.repra0);Uniform_array.unsafe_sett(offset+2)(Obj.repra1);Uniform_array.unsafe_sett(offset+3)(Obj.repra2);Uniform_array.unsafe_sett(offset+4)(Obj.repra3);Uniform_array.unsafe_sett(offset+5)(Obj.repra4);Uniform_array.unsafe_sett(offset+6)(Obj.repra5);Uniform_array.unsafe_sett(offset+7)(Obj.repra6);Uniform_array.unsafe_sett(offset+8)(Obj.repra7);Uniform_array.unsafe_sett(offset+9)(Obj.repra8);pointer;;letnew10ta0a1a2a3a4a5a6a7a8a9=letpointer=malloctinletoffset=Pointer.header_indexpointerinUniform_array.unsafe_sett(offset+1)(Obj.repra0);Uniform_array.unsafe_sett(offset+2)(Obj.repra1);Uniform_array.unsafe_sett(offset+3)(Obj.repra2);Uniform_array.unsafe_sett(offset+4)(Obj.repra3);Uniform_array.unsafe_sett(offset+5)(Obj.repra4);Uniform_array.unsafe_sett(offset+6)(Obj.repra5);Uniform_array.unsafe_sett(offset+7)(Obj.repra6);Uniform_array.unsafe_sett(offset+8)(Obj.repra7);Uniform_array.unsafe_sett(offset+9)(Obj.repra8);Uniform_array.unsafe_sett(offset+10)(Obj.repra9);pointer;;letnew11ta0a1a2a3a4a5a6a7a8a9a10=letpointer=malloctinletoffset=Pointer.header_indexpointerinUniform_array.unsafe_sett(offset+1)(Obj.repra0);Uniform_array.unsafe_sett(offset+2)(Obj.repra1);Uniform_array.unsafe_sett(offset+3)(Obj.repra2);Uniform_array.unsafe_sett(offset+4)(Obj.repra3);Uniform_array.unsafe_sett(offset+5)(Obj.repra4);Uniform_array.unsafe_sett(offset+6)(Obj.repra5);Uniform_array.unsafe_sett(offset+7)(Obj.repra6);Uniform_array.unsafe_sett(offset+8)(Obj.repra7);Uniform_array.unsafe_sett(offset+9)(Obj.repra8);Uniform_array.unsafe_sett(offset+10)(Obj.repra9);Uniform_array.unsafe_sett(offset+11)(Obj.repra10);pointer;;letnew12ta0a1a2a3a4a5a6a7a8a9a10a11=letpointer=malloctinletoffset=Pointer.header_indexpointerinUniform_array.unsafe_sett(offset+1)(Obj.repra0);Uniform_array.unsafe_sett(offset+2)(Obj.repra1);Uniform_array.unsafe_sett(offset+3)(Obj.repra2);Uniform_array.unsafe_sett(offset+4)(Obj.repra3);Uniform_array.unsafe_sett(offset+5)(Obj.repra4);Uniform_array.unsafe_sett(offset+6)(Obj.repra5);Uniform_array.unsafe_sett(offset+7)(Obj.repra6);Uniform_array.unsafe_sett(offset+8)(Obj.repra7);Uniform_array.unsafe_sett(offset+9)(Obj.repra8);Uniform_array.unsafe_sett(offset+10)(Obj.repra9);Uniform_array.unsafe_sett(offset+11)(Obj.repra10);Uniform_array.unsafe_sett(offset+12)(Obj.repra11);pointer;;letnew13ta0a1a2a3a4a5a6a7a8a9a10a11a12=letpointer=malloctinletoffset=Pointer.header_indexpointerinUniform_array.unsafe_sett(offset+1)(Obj.repra0);Uniform_array.unsafe_sett(offset+2)(Obj.repra1);Uniform_array.unsafe_sett(offset+3)(Obj.repra2);Uniform_array.unsafe_sett(offset+4)(Obj.repra3);Uniform_array.unsafe_sett(offset+5)(Obj.repra4);Uniform_array.unsafe_sett(offset+6)(Obj.repra5);Uniform_array.unsafe_sett(offset+7)(Obj.repra6);Uniform_array.unsafe_sett(offset+8)(Obj.repra7);Uniform_array.unsafe_sett(offset+9)(Obj.repra8);Uniform_array.unsafe_sett(offset+10)(Obj.repra9);Uniform_array.unsafe_sett(offset+11)(Obj.repra10);Uniform_array.unsafe_sett(offset+12)(Obj.repra11);Uniform_array.unsafe_sett(offset+13)(Obj.repra12);pointer;;letnew14ta0a1a2a3a4a5a6a7a8a9a10a11a12a13=letpointer=malloctinletoffset=Pointer.header_indexpointerinUniform_array.unsafe_sett(offset+1)(Obj.repra0);Uniform_array.unsafe_sett(offset+2)(Obj.repra1);Uniform_array.unsafe_sett(offset+3)(Obj.repra2);Uniform_array.unsafe_sett(offset+4)(Obj.repra3);Uniform_array.unsafe_sett(offset+5)(Obj.repra4);Uniform_array.unsafe_sett(offset+6)(Obj.repra5);Uniform_array.unsafe_sett(offset+7)(Obj.repra6);Uniform_array.unsafe_sett(offset+8)(Obj.repra7);Uniform_array.unsafe_sett(offset+9)(Obj.repra8);Uniform_array.unsafe_sett(offset+10)(Obj.repra9);Uniform_array.unsafe_sett(offset+11)(Obj.repra10);Uniform_array.unsafe_sett(offset+12)(Obj.repra11);Uniform_array.unsafe_sett(offset+13)(Obj.repra12);Uniform_array.unsafe_sett(offset+14)(Obj.repra13);pointer;;letgettpslot=Obj.obj(Uniform_array.gett(Pointer.slot_indexpslot))letunsafe_gettpslot=Obj.obj(Uniform_array.unsafe_gett(Pointer.slot_indexpslot));;letsettpslotx=Uniform_array.sett(Pointer.slot_indexpslot)(Obj.reprx)letunsafe_settpslotx=Uniform_array.unsafe_sett(Pointer.slot_indexpslot)(Obj.reprx);;letget_tuple(typetuple)(t:(tuple,_)Slots.tt)pointer=letmetadata=metadatatinletlen=metadata.slots_per_tupleiniflen=1thengettpointerSlot.t0else(Obj.magic(Uniform_array.subt~pos:(Pointer.first_slot_indexpointer)~len:Obj.tUniform_array.t):tuple);;endincludePoolmoduleUnsafe=structincludePoolletcreateslots~capacity=create_with_dummyslots~capacity~dummy:NoneendmoduleDebug(Pool:S)=structopenPoolletcheck_invariant=reftrueletshow_messages=reftrueletdebugnametsargsexp_of_argsexp_of_resultf=letprefix="Pool."inif!check_invariantthenList.iterts~f:(invariantignore);if!show_messagesthenDebug.eprints(concat[prefix;name])argsexp_of_arg;letresult_or_exn=Result.try_withfinif!show_messagesthenDebug.eprints(concat[prefix;name;" result"])result_or_exn[%sexp_of:(result,exn)Result.t];Result.ok_exnresult_or_exn;;moduleSlots=SlotsmoduleSlot=SlotmodulePointer=structopenPointertypenonrec'slotst='slotst[@@derivingsexp_of,typerep]letphys_comparet1t2=debug"Pointer.phys_compare"[](t1,t2)[%sexp_of:_t*_t][%sexp_of:int](fun()->phys_comparet1t2);;letphys_equalt1t2=debug"Pointer.phys_equal"[](t1,t2)[%sexp_of:_t*_t][%sexp_of:bool](fun()->phys_equalt1t2);;letis_nullt=debug"Pointer.is_null"[]t[%sexp_of:_t][%sexp_of:bool](fun()->is_nullt);;letnull=nullmoduleId=structopenIdtypenonrect=t[@@derivingbin_io,sexp]letof_int63i=debug"Pointer.Id.of_int63"[]i[%sexp_of:Int63.t][%sexp_of:t](fun()->of_int63i);;letto_int63t=debug"Pointer.Id.to_int63"[]t[%sexp_of:t][%sexp_of:Int63.t](fun()->to_int63t);;endendtypenonrec'slotst='slotst[@@derivingsexp_of]letinvariant=invariantletlength=lengthletid_of_pointertpointer=debug"id_of_pointer"[t]pointer[%sexp_of:_Pointer.t][%sexp_of:Pointer.Id.t](fun()->id_of_pointertpointer);;letpointer_of_id_exntid=debug"pointer_of_id_exn"[t]id[%sexp_of:Pointer.Id.t][%sexp_of:_Pointer.t](fun()->pointer_of_id_exntid);;letpointer_is_validtpointer=debug"pointer_is_valid"[t]pointer[%sexp_of:_Pointer.t][%sexp_of:bool](fun()->pointer_is_validtpointer);;letcreateslots~capacity~dummy=debug"create"[]capacity[%sexp_of:int][%sexp_of:_t](fun()->createslots~capacity~dummy);;letmax_capacity~slots_per_tuple=debug"max_capacity"[]slots_per_tuple[%sexp_of:int][%sexp_of:int](fun()->max_capacity~slots_per_tuple);;letcapacityt=debug"capacity"[t]t[%sexp_of:_t][%sexp_of:int](fun()->capacityt);;letgrow?capacityt=debug"grow"[t](`capacitycapacity)[%sexp_of:[`capacityofintoption]][%sexp_of:_t](fun()->grow?capacityt);;letis_fullt=debug"is_full"[t]t[%sexp_of:_t][%sexp_of:bool](fun()->is_fullt);;letunsafe_freetp=debug"unsafe_free"[t]p[%sexp_of:_Pointer.t][%sexp_of:unit](fun()->unsafe_freetp);;letfreetp=debug"free"[t]p[%sexp_of:_Pointer.t][%sexp_of:unit](fun()->freetp);;letdebug_newtf=debug"new"[t]()[%sexp_of:unit][%sexp_of:_Pointer.t]fletnew1ta0=debug_newt(fun()->new1ta0)letnew2ta0a1=debug_newt(fun()->new2ta0a1)letnew3ta0a1a2=debug_newt(fun()->new3ta0a1a2)letnew4ta0a1a2a3=debug_newt(fun()->new4ta0a1a2a3)letnew5ta0a1a2a3a4=debug_newt(fun()->new5ta0a1a2a3a4)letnew6ta0a1a2a3a4a5=debug_newt(fun()->new6ta0a1a2a3a4a5)letnew7ta0a1a2a3a4a5a6=debug_newt(fun()->new7ta0a1a2a3a4a5a6)letnew8ta0a1a2a3a4a5a6a7=debug_newt(fun()->new8ta0a1a2a3a4a5a6a7);;letnew9ta0a1a2a3a4a5a6a7a8=debug_newt(fun()->new9ta0a1a2a3a4a5a6a7a8);;letnew10ta0a1a2a3a4a5a6a7a8a9=debug_newt(fun()->new10ta0a1a2a3a4a5a6a7a8a9);;letnew11ta0a1a2a3a4a5a6a7a8a9a10=debug_newt(fun()->new11ta0a1a2a3a4a5a6a7a8a9a10);;letnew12ta0a1a2a3a4a5a6a7a8a9a10a11=debug_newt(fun()->new12ta0a1a2a3a4a5a6a7a8a9a10a11);;letnew13ta0a1a2a3a4a5a6a7a8a9a10a11a12=debug_newt(fun()->new13ta0a1a2a3a4a5a6a7a8a9a10a11a12);;letnew14ta0a1a2a3a4a5a6a7a8a9a10a11a12a13=debug_newt(fun()->new14ta0a1a2a3a4a5a6a7a8a9a10a11a12a13);;letget_tupletpointer=debug"get_tuple"[t]pointer[%sexp_of:_Pointer.t][%sexp_of:_](fun()->get_tupletpointer);;letdebug_getnameftpointer=debugname[t]pointer[%sexp_of:_Pointer.t][%sexp_of:_](fun()->ftpointer);;letgettpointerslot=debug_get"get"gettpointerslotletunsafe_gettpointerslot=debug_get"unsafe_get"unsafe_gettpointerslotletdebug_setnameftpointerslota=debugname[t]pointer[%sexp_of:_Pointer.t][%sexp_of:unit](fun()->ftpointerslota);;letsettpointerslota=debug_set"set"settpointerslotaletunsafe_settpointerslota=debug_set"unsafe_set"unsafe_settpointerslotaendmoduleError_check(Pool:S)=structopenPoolmoduleSlots=SlotsmoduleSlot=SlotmodulePointer=structtype'slotst={mutableis_valid:bool;pointer:'slotsPointer.t}[@@derivingsexp_of,typerep]letcreatepointer={is_valid=true;pointer}letnull()={is_valid=false;pointer=Pointer.null()}letphys_comparet1t2=Pointer.phys_comparet1.pointert2.pointerletphys_equalt1t2=Pointer.phys_equalt1.pointert2.pointerletis_nullt=Pointer.is_nullt.pointerletfollowt=ifnott.is_validthenfailwiths"attempt to use invalid pointer"t[%sexp_of:_t];t.pointer;;letinvalidatet=t.is_valid<-falsemoduleId=Pointer.Idendtype'slotst='slotsPool.t[@@derivingsexp_of]letinvariant=invariantletlength=lengthletpointer_is_validt{Pointer.is_valid;pointer}=is_valid&&pointer_is_validtpointer;;(* We don't do [Pointer.follow pointer], because that would disallow [id_of_pointer t
(Pointer.null ())]. *)letid_of_pointertpointer=id_of_pointertpointer.Pointer.pointerletpointer_of_id_exntid=letpointer=pointer_of_id_exntidinletis_valid=Pool.pointer_is_validtpointerin{Pointer.is_valid;pointer};;letcreate=createletcapacity=capacityletmax_capacity=max_capacityletgrow=growletis_full=is_fullletget_tupletp=get_tuplet(Pointer.followp)letgettp=gett(Pointer.followp)letunsafe_gettp=unsafe_gett(Pointer.followp)letsettpslotv=sett(Pointer.followp)slotvletunsafe_settpslotv=unsafe_sett(Pointer.followp)slotvletunsafe_freetp=unsafe_freet(Pointer.followp);Pointer.invalidatep;;letfreetp=freet(Pointer.followp);Pointer.invalidatep;;letnew1ta0=Pointer.create(Pool.new1ta0)letnew2ta0a1=Pointer.create(Pool.new2ta0a1)letnew3ta0a1a2=Pointer.create(Pool.new3ta0a1a2)letnew4ta0a1a2a3=Pointer.create(Pool.new4ta0a1a2a3)letnew5ta0a1a2a3a4=Pointer.create(Pool.new5ta0a1a2a3a4)letnew6ta0a1a2a3a4a5=Pointer.create(Pool.new6ta0a1a2a3a4a5)letnew7ta0a1a2a3a4a5a6=Pointer.create(Pool.new7ta0a1a2a3a4a5a6)letnew8ta0a1a2a3a4a5a6a7=Pointer.create(Pool.new8ta0a1a2a3a4a5a6a7);;letnew9ta0a1a2a3a4a5a6a7a8=Pointer.create(Pool.new9ta0a1a2a3a4a5a6a7a8);;letnew10ta0a1a2a3a4a5a6a7a8a9=Pointer.create(Pool.new10ta0a1a2a3a4a5a6a7a8a9);;letnew11ta0a1a2a3a4a5a6a7a8a9a10=Pointer.create(Pool.new11ta0a1a2a3a4a5a6a7a8a9a10);;letnew12ta0a1a2a3a4a5a6a7a8a9a10a11=Pointer.create(Pool.new12ta0a1a2a3a4a5a6a7a8a9a10a11);;letnew13ta0a1a2a3a4a5a6a7a8a9a10a11a12=Pointer.create(Pool.new13ta0a1a2a3a4a5a6a7a8a9a10a11a12);;letnew14ta0a1a2a3a4a5a6a7a8a9a10a11a12a13=Pointer.create(Pool.new14ta0a1a2a3a4a5a6a7a8a9a10a11a12a13);;end