123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792(**************************************************************************)(* *)(* OCaml *)(* *)(* Jacques Garrigue, Kyoto University RIMS *)(* Antal Spector-Zabusky, Jane Street, New York *)(* *)(* Copyright 2001 Institut National de Recherche en Informatique et *)(* en Automatique. *)(* Copyright 2023 Jane Street Group LLC *)(* *)(* All rights reserved. This file is distributed under the terms of *)(* the GNU Lesser General Public License version 2.1, with the *)(* special exception on linking described in the file LICENSE. *)(* *)(**************************************************************************)open!Stdlib[@@@ocaml.flambda_o3](* Module [IarrayLabels]: labelled Iarray module *)[@@@ocaml.nolabels](* NOTE: Please work in iarray.ml and then copy the results here; for more
information, see the top of that file. This is a temporary state of affairs,
but for now, please copy things! *)(* CR mshinwell: Change to "include Iarray"; we can't do this at present
as it requires referencing Stdlib__Iarray which will work under the make
build but not under dune. *)(* An alias for the type of immutable arrays. *)type(+'a:anymodseparable)t='aiarray(* Array operations *)externallength:('a:anymodseparable).local_'aiarray->int@@portable="%array_length"[@@layout_poly]externalget:('a:anymodseparable).('aiarray[@local_opt])->int->('a[@local_opt])@@portable="%array_safe_get"[@@layout_poly]external(.:()):('a:anymodseparable).('aiarray[@local_opt])->int->('a[@local_opt])@@portable="%array_safe_get"[@@layout_poly]externalunsafe_get:('a:anymodseparable).('aiarray[@local_opt])->int->('a[@local_opt])@@portable="%array_unsafe_get"[@@layout_poly]externalconcat:('a:anymodseparable).'aiarraylist->'aiarray@@portable="caml_array_concat"externalconcat_local:('a:anymodseparable).local_'aiarraylist->local_'aiarray@@portable="caml_array_concat_local"externalappend_prim:('a:anymodseparable).'aiarray->'aiarray->'aiarray@@portable="caml_array_append"externalappend_prim_local:('a:anymodseparable).local_'aiarray->local_'aiarray->local_'aiarray@@portable="caml_array_append_local"externalunsafe_sub:('a:anymodseparable).'aiarray->int->int->'aiarray@@portable="caml_array_sub"externalunsafe_sub_local:('a:anymodseparable).local_'aiarray->int->int->local_'aiarray@@portable="caml_array_sub_local"externalunsafe_of_array:('a:anymodseparable).'aarray->'aiarray@@portable="%array_to_iarray"externalunsafe_to_array:('a:anymodseparable).'aiarray->'aarray@@portable="%array_of_iarray"(* Used only to reimplement [init] *)externalunsafe_set_mutable:('a:anymodseparable).'aarray->int->'a->unit@@portable="%array_unsafe_set"[@@layout_poly](* VERY UNSAFE: Any of these functions can be used to violate the "no forward
pointers" restriction for the local stack if not used carefully. Each of
these can either make a local mutable array or mutate its contents, and if
not careful, this can lead to an array's contents pointing forwards. *)externalmake_mutable_local:('a:value_or_nullmodseparable).int->local_'a->local_'aarray@@portable="caml_array_make_local"externalunsafe_of_local_array:('a:anymodseparable).local_'aarray->local_'aiarray@@portable="%array_to_iarray"externalunsafe_set_local:('a:anymodseparable).local_'aarray->int->local_'a->unit@@portable="%array_unsafe_set"[@@layout_poly](* We can't use immutable array literals in this file, since we don't want to
require the stdlib to be compiled with extensions, so instead of [[::]] we
use [unsafe_of_array [||]] below. Thankfully, we never need it in the
[local] case so we don't have to think about the details. *)(* Really trusting the inliner here; to get maximum performance, it has to
inline both [unsafe_init_local] *and* [f]. *)(** Precondition: [l >= 0]. *)let[@inlinealways]unsafe_init_locall(local_f:int->local_'a)=exclave_ifl=0thenunsafe_of_local_array[||]else(* The design of this function is exceedingly delicate, and is the only way
we can correctly allocate a local array on the stack via mutation. We
are subject to the "no forward pointers" constraint on the local stack;
we're not allowed to make pointers to later-allocated objects even within
the same stack frame. Thus, in order to get this right, we consume O(n)
call-stack space: we allocate the values to put in the array, and only
*then* recurse, creating the array as the very last thing of all and
*returning* it. This is why the [f i] call is the first thing in the
function, and why it's not tail-recursive; if it were tail-recursive,
then we wouldn't have anywhere to put the array elements during the whole
process. *)letrecgo~l~fi=exclave_beginletx=fiinifi=l-1thenmake_mutable_locallxelsebeginletres=go~l~f(i+1)inunsafe_set_localresix;resendendinunsafe_of_local_array(go~l~f0)(* The implementation is copied from [Array] so that [f] can be [local_] *)letinitl(local_f)=ifl=0thenunsafe_of_array[||]elseifl<0theninvalid_arg"Iarray.init"(* See #6575. We could also check for maximum array size, but this depends
on whether we create a float array or a regular one... *)elseletres=Array.makel(f0)infori=1topredldounsafe_set_mutableresi(fi)done;unsafe_of_arrayresletinit_locallf=exclave_ifl<0theninvalid_arg"Iarray.init_local"(* See #6575. We could also check for maximum array size, but this depends
on whether we create a float array or a regular one... *)elseunsafe_init_locallfletappenda1a2=iflengtha1=0thena2(* Safe because they're immutable *)elseiflengtha2=0thena1elseappend_prima1a2letappend_locala1a2=exclave_iflengtha1=0thena2(* Safe because they're immutable *)elseiflengtha2=0thena1elseappend_prim_locala1a2letsubaofslen=ifofs<0||len<0||ofs>lengtha-lentheninvalid_arg"Iarray.sub"elseunsafe_subaofslenletsub_localaofslen=exclave_ifofs<0||len<0||ofs>lengtha-lentheninvalid_arg"Iarray.sub"elseunsafe_sub_localaofslenletiterfa=fori=0tolengtha-1dof(unsafe_getai)doneletiter_localfa=fori=0tolengtha-1dof(unsafe_getai)doneletiter2fab=iflengtha<>lengthbtheninvalid_arg"Iarray.iter2: arrays must have the same length"elsefori=0tolengtha-1dof(unsafe_getai)(unsafe_getbi)doneletiter2_localfab=iflengtha<>lengthbtheninvalid_arg"Iarray.iter2_local: arrays must have the same length"elsefori=0tolengtha-1dof(unsafe_getai)(unsafe_getbi)doneletiter2_local_firstfab=iflengtha<>lengthbtheninvalid_arg"Iarray.iter2_local_first: arrays must have the same length"elsefori=0tolengtha-1dof(unsafe_getai)(unsafe_getbi)doneletiter2_local_secondfab=iflengtha<>lengthbtheninvalid_arg"Iarray.iter2_local_second: arrays must have the same length"elsefori=0tolengtha-1dof(unsafe_getai)(unsafe_getbi)doneletmapfa=letl=lengthainifl=0thenunsafe_of_array[||]elsebeginletr=Array.makel(f(unsafe_geta0))infori=1tol-1doArray.unsafe_setri(f(unsafe_getai))done;unsafe_of_arrayrendletmap_localfa=exclave_unsafe_init_local(lengtha)(funi->exclave_f(unsafe_getai))letmap_local_inputfa=letl=lengthainifl=0thenunsafe_of_array[||]elsebeginletr=Array.makel(f(unsafe_geta0))infori=1tol-1doArray.unsafe_setri(f(unsafe_getai))done;unsafe_of_arrayrendletmap_local_outputfa=exclave_unsafe_init_local(lengtha)(funi->exclave_f(unsafe_getai))letmap2fab=letla=lengthainletlb=lengthbinifla<>lbtheninvalid_arg"Iarray.map2: arrays must have the same length"elsebeginifla=0thenunsafe_of_array[||]elsebeginletr=Array.makela(f(unsafe_geta0)(unsafe_getb0))infori=1tola-1doArray.unsafe_setri(f(unsafe_getai)(unsafe_getbi))done;unsafe_of_arrayrendendletmap2_localfab=exclave_letla=lengthainletlb=lengthbinifla<>lbtheninvalid_arg"Iarray.map2_local: arrays must have the same length"elseunsafe_init_localla(funi->exclave_f(unsafe_getai)(unsafe_getbi))letmap2_local_inputsfab=letla=lengthainletlb=lengthbinifla<>lbtheninvalid_arg"Iarray.map2: arrays must have the same length"elsebeginifla=0thenunsafe_of_array[||]elsebeginletr=Array.makela(f(unsafe_geta0)(unsafe_getb0))infori=1tola-1doArray.unsafe_setri(f(unsafe_getai)(unsafe_getbi))done;unsafe_of_arrayrendendletmap2_local_outputfab=exclave_letla=lengthainletlb=lengthbinifla<>lbtheninvalid_arg"Iarray.map2_local: arrays must have the same length"elseunsafe_init_localla(funi->exclave_f(unsafe_getai)(unsafe_getbi))letmap2_local_first_inputfab=letla=lengthainletlb=lengthbinifla<>lbtheninvalid_arg"Iarray.map2: arrays must have the same length"elsebeginifla=0thenunsafe_of_array[||]elsebeginletr=Array.makela(f(unsafe_geta0)(unsafe_getb0))infori=1tola-1doArray.unsafe_setri(f(unsafe_getai)(unsafe_getbi))done;unsafe_of_arrayrendendletmap2_local_second_inputfab=letla=lengthainletlb=lengthbinifla<>lbtheninvalid_arg"Iarray.map2: arrays must have the same length"elsebeginifla=0thenunsafe_of_array[||]elsebeginletr=Array.makela(f(unsafe_geta0)(unsafe_getb0))infori=1tola-1doArray.unsafe_setri(f(unsafe_getai)(unsafe_getbi))done;unsafe_of_arrayrendendletmap2_local_first_input_and_outputfab=exclave_letla=lengthainletlb=lengthbinifla<>lbtheninvalid_arg"Iarray.map2_local: arrays must have the same length"elseunsafe_init_localla(funi->exclave_f(unsafe_getai)(unsafe_getbi))letmap2_local_second_input_and_outputfab=exclave_letla=lengthainletlb=lengthbinifla<>lbtheninvalid_arg"Iarray.map2_local: arrays must have the same length"elseunsafe_init_localla(funi->exclave_f(unsafe_getai)(unsafe_getbi))letiterifa=fori=0tolengtha-1dofi(unsafe_getai)doneletiteri_localfa=fori=0tolengtha-1dofi(unsafe_getai)doneletmapifa=letl=lengthainifl=0thenunsafe_of_array[||]elsebeginletr=Array.makel(f0(unsafe_geta0))infori=1tol-1doArray.unsafe_setri(fi(unsafe_getai))done;unsafe_of_arrayrendletmapi_localfa=exclave_unsafe_init_local(lengtha)(funi->exclave_fi(unsafe_getai))letmapi_local_inputfa=letl=lengthainifl=0thenunsafe_of_array[||]elsebeginletr=Array.makel(f0(unsafe_geta0))infori=1tol-1doArray.unsafe_setri(fi(unsafe_getai))done;unsafe_of_arrayrendletmapi_local_outputfa=exclave_unsafe_init_local(lengtha)(funi->exclave_fi(unsafe_getai))letto_lista=letrectolistires=ifi<0thenreselsetolist(i-1)(unsafe_getai::res)intolist(lengtha-1)[]letto_list_locala=exclave_letrectolistires=exclave_ifi<0thenreselsetolist(i-1)(unsafe_getai::res)intolist(lengtha-1)[]letof_listl=unsafe_of_array(Array.of_listl)(* Cannot use List.length here because the List module depends on Array. *)letreclist_lengthaccu=function|[]->accu|_::t->list_length(succaccu)t(* This shouldn't violate the forward-pointers restriction because the list
elements already exist *)letof_list_local=function|[]->exclave_unsafe_of_array[||]|hd::tlasl->exclave_leta=make_mutable_local(list_length0l)hdinletrecfilli=function|[]->exclave_a|hd::tl->exclave_unsafe_set_localaihd;fill(i+1)tlinunsafe_of_local_array(fill1tl)letto_arrayia=Array.copy(unsafe_to_arrayia)letof_arrayma=unsafe_of_array(Array.copyma)letfold_leftfxa=letr=refxinfori=0tolengtha-1dor:=f!r(unsafe_getai)done;!rletfold_left_localfxa=exclave_letlen=lengthainletrecgori=exclave_ifi=lenthenrelsego(fr(unsafe_getai))(i+1)ingox0letfold_left_local_inputfxa=letr=refxinfori=0tolengtha-1dor:=f!r(unsafe_getai)done;!rletfold_left_local_outputfxa=exclave_letlen=lengthainletrecgori=exclave_ifi=lenthenrelsego(fr(unsafe_getai))(i+1)ingox0letfold_left_mapfaccinput_array=letlen=lengthinput_arrayiniflen=0then(acc,unsafe_of_array[||])elsebeginletacc,elt=facc(unsafe_getinput_array0)inletoutput_array=Array.makeleneltinletacc=refaccinfori=1tolen-1doletacc',elt=f!acc(unsafe_getinput_arrayi)inacc:=acc';Array.unsafe_setoutput_arrayielt;done;!acc,unsafe_of_arrayoutput_arrayendletfold_left_map_localfaccinput_array=exclave_letlen=lengthinput_arrayiniflen=0then(acc,unsafe_of_local_array[||])elsebeginletrecgoacci=exclave_letacc,elt=facc(unsafe_getinput_arrayi)inifi=len-1thenacc,make_mutable_localleneltelsebeginlet(_,output_array)asres=goacc(i+1)inunsafe_set_localoutput_arrayielt;resendinletacc,output_array=goacc0inacc,unsafe_of_local_arrayoutput_arrayendletfold_left_map_local_inputfaccinput_array=letlen=lengthinput_arrayiniflen=0then(acc,unsafe_of_array[||])elsebeginletacc,elt=facc(unsafe_getinput_array0)inletoutput_array=Array.makeleneltinletacc=refaccinfori=1tolen-1doletacc',elt=f!acc(unsafe_getinput_arrayi)inacc:=acc';Array.unsafe_setoutput_arrayielt;done;!acc,unsafe_of_arrayoutput_arrayendletfold_left_map_local_outputfaccinput_array=exclave_letlen=lengthinput_arrayiniflen=0then(acc,unsafe_of_local_array[||])elsebeginletrecgoacci=exclave_letacc,elt=facc(unsafe_getinput_arrayi)inifi=len-1thenacc,make_mutable_localleneltelsebeginlet(_,output_array)asres=goacc(i+1)inunsafe_set_localoutput_arrayielt;resendinletacc,output_array=goacc0inacc,unsafe_of_local_arrayoutput_arrayendletfold_rightfax=letr=refxinfori=lengtha-1downto0dor:=f(unsafe_getai)!rdone;!rletfold_right_localfax=exclave_letrecgori=exclave_ifi=-1thenrelsego(f(unsafe_getai)r)(i-1)ingox(lengtha-1)letfold_right_local_inputfax=letr=refxinfori=lengtha-1downto0dor:=f(unsafe_getai)!rdone;!rletfold_right_local_outputfax=exclave_letrecgori=exclave_ifi=-1thenrelsego(f(unsafe_getai)r)(i-1)ingox(lengtha-1)(* CR aspectorzabusky: Why do I need this? Shouldn't mode-crossing handle doing
this? *)let[@inlinealways]globalize_bool:local_bool->bool=funb->bletexistspa=letn=lengthainletrecloopi=exclave_ifi=nthenfalseelseifp(unsafe_getai)thentrueelseloop(succi)inglobalize_bool(loop0)letexists_localpa=letn=lengthainletrecloopi=exclave_ifi=nthenfalseelseifp(unsafe_getai)thentrueelseloop(succi)inglobalize_bool(loop0)letfor_allpa=letn=lengthainletrecloopi=exclave_ifi=nthentrueelseifp(unsafe_getai)thenloop(succi)elsefalseinglobalize_bool(loop0)letfor_all_localpa=letn=lengthainletrecloopi=exclave_ifi=nthentrueelseifp(unsafe_getai)thenloop(succi)elsefalseinglobalize_bool(loop0)letfor_all2pl1l2=letn1=lengthl1andn2=lengthl2inifn1<>n2theninvalid_arg"Iarray.for_all2"elseletrecloopi=exclave_ifi=n1thentrueelseifp(unsafe_getl1i)(unsafe_getl2i)thenloop(succi)elsefalseinglobalize_bool(loop0)letfor_all2_localpl1l2=letn1=lengthl1andn2=lengthl2inifn1<>n2theninvalid_arg"Iarray.for_all2_local"elseletrecloopi=exclave_ifi=n1thentrueelseifp(unsafe_getl1i)(unsafe_getl2i)thenloop(succi)elsefalseinglobalize_bool(loop0)letfor_all2_local_firstpl1l2=letn1=lengthl1andn2=lengthl2inifn1<>n2theninvalid_arg"Iarray.for_all2_local_first"elseletrecloopi=exclave_ifi=n1thentrueelseifp(unsafe_getl1i)(unsafe_getl2i)thenloop(succi)elsefalseinglobalize_bool(loop0)letfor_all2_local_secondpl1l2=letn1=lengthl1andn2=lengthl2inifn1<>n2theninvalid_arg"Iarray.for_all2_local_second"elseletrecloopi=exclave_ifi=n1thentrueelseifp(unsafe_getl1i)(unsafe_getl2i)thenloop(succi)elsefalseinglobalize_bool(loop0)letexists2pl1l2=letn1=lengthl1andn2=lengthl2inifn1<>n2theninvalid_arg"Iarray.exists2"elseletrecloopi=exclave_ifi=n1thenfalseelseifp(unsafe_getl1i)(unsafe_getl2i)thentrueelseloop(succi)inglobalize_bool(loop0)letexists2_localpl1l2=letn1=lengthl1andn2=lengthl2inifn1<>n2theninvalid_arg"Iarray.exists2_local"elseletrecloopi=exclave_ifi=n1thenfalseelseifp(unsafe_getl1i)(unsafe_getl2i)thentrueelseloop(succi)inglobalize_bool(loop0)letexists2_local_firstpl1l2=letn1=lengthl1andn2=lengthl2inifn1<>n2theninvalid_arg"Iarray.exists2_local_first"elseletrecloopi=exclave_ifi=n1thenfalseelseifp(unsafe_getl1i)(unsafe_getl2i)thentrueelseloop(succi)inglobalize_bool(loop0)letexists2_local_secondpl1l2=letn1=lengthl1andn2=lengthl2inifn1<>n2theninvalid_arg"Iarray.exists2_local_second"elseletrecloopi=exclave_ifi=n1thenfalseelseifp(unsafe_getl1i)(unsafe_getl2i)thentrueelseloop(succi)inglobalize_bool(loop0)letmemxa=letn=lengthainletrecloopi=exclave_ifi=nthenfalseelseifcompare(unsafe_getai)x=0thentrueelseloop(succi)inglobalize_bool(loop0)letmemqxa=letn=lengthainletrecloopi=exclave_ifi=nthenfalseelseifx==(unsafe_getai)thentrueelseloop(succi)inglobalize_bool(loop0)letfind_optpa=letn=lengthainletrecloopi=ifi=nthenNoneelseletx=unsafe_getaiinifpxthenSomexelseloop(succi)inloop0[@nontail]letfind_opt_localpa=exclave_letn=lengthainletrecloopi=exclave_ifi=nthenNoneelseletx=unsafe_getaiinifpxthenSomexelseloop(succi)inloop0letfind_mapfa=letn=lengthainletrecloopi=ifi=nthenNoneelsematchf(unsafe_getai)with|None->loop(succi)|Some_asr->rinloop0[@nontail]letfind_map_localfa=exclave_letn=lengthainletrecloopi=exclave_ifi=nthenNoneelsematchf(unsafe_getai)with|None->loop(succi)|Some_asr->rinloop0letfind_map_local_inputfa=letn=lengthainletrecloopi=ifi=nthenNoneelsematchf(unsafe_getai)with|None->loop(succi)|Some_asr->rinloop0[@nontail]letfind_map_local_outputfa=exclave_letn=lengthainletrecloopi=exclave_ifi=nthenNoneelsematchf(unsafe_getai)with|None->loop(succi)|Some_asr->rinloop0letsplitx=ifx=unsafe_of_array[||]thenunsafe_of_array[||],unsafe_of_array[||]elsebeginleta0,b0=unsafe_getx0inletn=lengthxinleta=Array.makena0inletb=Array.makenb0infori=1ton-1doletai,bi=unsafe_getxiinArray.unsafe_setaiai;Array.unsafe_setbibidone;unsafe_of_arraya,unsafe_of_arraybend(* This shouldn't violate the forward-pointers restriction because the array
elements already exist. (This doesn't work for [combine], where we need to
create the tuples.) *)letsplit_localx=exclave_ifx=unsafe_of_array[||]thenunsafe_of_array[||],unsafe_of_array[||]elsebeginleta0,b0=unsafe_getx0inletn=lengthxinleta=make_mutable_localna0inletb=make_mutable_localnb0infori=1ton-1doletai,bi=unsafe_getxiinunsafe_set_localaiai;unsafe_set_localbibidone;unsafe_of_local_arraya,unsafe_of_local_arraybendletcombineab=letna=lengthainletnb=lengthbinifna<>nbtheninvalid_arg"Iarray.combine";letr=ifna=0then[||]elsebeginletx=Array.makena(unsafe_geta0,unsafe_getb0)infori=1tona-1doArray.unsafe_setxi(unsafe_getai,unsafe_getbi)done;xendinunsafe_of_arrayrletcombine_localab=exclave_letna=lengthainletnb=lengthbinifna<>nbtheninvalid_arg"Iarray.combine_local";unsafe_init_localna(funi->exclave_unsafe_getai,unsafe_getbi)(* Must be fully applied due to the value restriction *)letlift_sortsortercmpiarr=letarr=to_arrayiarrinsortercmparr;unsafe_of_arrayarrletsortcmpiarr=lift_sortArray.sortcmpiarrletstable_sortcmpiarr=lift_sortArray.stable_sortcmpiarrletfast_sortcmpiarr=lift_sortArray.fast_sortcmpiarrletto_seqa=letrecauxi()=ifi<lengthathenletx=unsafe_getaiinSeq.Cons(x,aux(i+1))elseSeq.Nilinaux0letto_seqia=letrecauxi()=ifi<lengthathenletx=unsafe_getaiinSeq.Cons((i,x),aux(i+1))elseSeq.Nilinaux0letof_seqi=unsafe_of_array(Array.of_seqi)